Statistical Analysis: Absorption
Dana Swarbrick
12/11/2022
- Abstract with Questions
- Load data
- Import libraries
- Citations
- 3.1 Characterize Participant Sample
- 3.2.1 Internal Consistency
- Reduce Dimensionality
- Repeated Measures Correlations
- 3.4 Personal Characteristics and Absorption
- 3.5.1 Absorption ~ Group + Piece
- 3.5.2 Mind-Wandering ~ Group & Piece
- 3.6 Absorption & motion (and piece and group)
Note: I have attempted to include only the code that was used fro the results in the manuscript in this draft. # File Description This file contains the analyses for the absorption manuscript (Martin, Swarbrick, et al., 2023).
Abstract with Questions
Listeners’ musical absorption: Between attention and affect (Martin, Swarbrick, Nielsen, Høffding, Vuoskoski):
This was the text of the original proposed abstract (written by Martin) that was used to shape the results section.
“As musical experts, the Danish String Quartet (DSQ) can perform music in many different phases of individual and shared absorption and moreover maneuver between these phases consisting of multifaceted integrations of forms of attention and affect. Some related attentional and affective dynamics have also been identified in listeners’ reports of musical absorption (Herbert, 2019) as well as in more general accounts of music perception and consciousness (Clarke, 2011). We, however, have little understanding about how the listening experience generalizes across an entire audience and how it relates to relevant concepts in music psychology such as Kama Muta and trait empathy.
In this paper, we investigate the MusicLab Copenhagen audience members’ survey responses in relation to phenomenological and conceptual distinctions between absorption, affect, and attention. With a questionnaire, we cannot obtain a nuanced understanding of individual audience members’ phenomenology, [but instead we get some statistical significance from the over 100 responses.]”
“The paper uses the survey to answer a number of specific questions, namely:
What is the relation between on the one hand mind wandering and attention, and on the other hand absorption. What is the impact of previous musical training/acquaintance with the performed music/personal relation to the DSQ on absorption? What is the relation between absorption and the related concept from music psychology, Kama Muta. What is the relation between absorption and trait empathy? What is the relation between absorption and perceived movement of self and others as well as quantified movement of self and other. The answer to all of these questions, enables a structured conceptual discussion of the terms involved and a clarification of the role of affect, attention, empathy and movement in listeners’ musical absorption.”
Additionally, Swarbrick had questions on the impact of social context (live and livestreaming) and the piece of music (Beethoven, Schnittke, Folk) on absorption and its relation to motion.
Load data
df.full<-readRDS(file = "../output/Prepared_Data.Rda")
# rename ParticipantCode to Pt_ID because that is the name I began by using here.
names(df.full)[1]<-"Pt_ID"Import libraries
packages = c("GPArotation", "rmcorr", "ggpubr", "rstatix", "ltm","reshape2", "psych", "car", "emmeans", "nlme","lme4", "tidyverse", "ggsignif") #psych: Revelle, 2020; GPArotation: Bernaards and Jennrich, 2005) . rstatix and ggpubr for doing the RM -ANOVAs for checking the effect of awareness of body and movement on Absorption factor.
## Now load or install&load all
package.check <- lapply(
packages,
FUN = function(x) {
if (!require(x, character.only = TRUE)) {
install.packages(x, dependencies = TRUE)
library(x, character.only = TRUE)
}
}
)## Loading required package: GPArotation## Loading required package: rmcorr## Warning: package 'rmcorr' was built under R version 4.2.2## Loading required package: ggpubr## Loading required package: ggplot2## Loading required package: rstatix##
## Attaching package: 'rstatix'## The following object is masked from 'package:stats':
##
## filter## Loading required package: ltm## Loading required package: MASS##
## Attaching package: 'MASS'## The following object is masked from 'package:rstatix':
##
## select## Loading required package: msm## Loading required package: polycor## Loading required package: reshape2## Loading required package: psych##
## Attaching package: 'psych'## The following object is masked from 'package:ltm':
##
## factor.scores## The following object is masked from 'package:polycor':
##
## polyserial## The following objects are masked from 'package:ggplot2':
##
## %+%, alpha## Loading required package: car## Loading required package: carData##
## Attaching package: 'car'## The following object is masked from 'package:psych':
##
## logit## Loading required package: emmeans## Loading required package: nlme## Loading required package: lme4## Loading required package: Matrix##
## Attaching package: 'lme4'## The following object is masked from 'package:nlme':
##
## lmList## Loading required package: tidyverse## ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.1 ──## ✔ tibble 3.1.7 ✔ dplyr 1.0.9
## ✔ tidyr 1.2.0 ✔ stringr 1.4.0
## ✔ readr 2.1.2 ✔ forcats 0.5.1
## ✔ purrr 0.3.4## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ psych::%+%() masks ggplot2::%+%()
## ✖ psych::alpha() masks ggplot2::alpha()
## ✖ dplyr::collapse() masks nlme::collapse()
## ✖ tidyr::expand() masks Matrix::expand()
## ✖ dplyr::filter() masks rstatix::filter(), stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ✖ tidyr::pack() masks Matrix::pack()
## ✖ dplyr::recode() masks car::recode()
## ✖ dplyr::select() masks MASS::select(), rstatix::select()
## ✖ purrr::some() masks car::some()
## ✖ tidyr::unpack() masks Matrix::unpack()## Loading required package: ggsignifsource("useful_functions.R")Citations
citation()##
## To cite R in publications use:
##
## R Core Team (2022). R: A language and environment for statistical
## computing. R Foundation for Statistical Computing, Vienna, Austria.
## URL https://www.R-project.org/.
##
## A BibTeX entry for LaTeX users is
##
## @Manual{,
## title = {R: A Language and Environment for Statistical Computing},
## author = {{R Core Team}},
## organization = {R Foundation for Statistical Computing},
## address = {Vienna, Austria},
## year = {2022},
## url = {https://www.R-project.org/},
## }
##
## We have invested a lot of time and effort in creating R, please cite it
## when using it for data analysis. See also 'citation("pkgname")' for
## citing R packages.citation("lme4")##
## To cite lme4 in publications use:
##
## Douglas Bates, Martin Maechler, Ben Bolker, Steve Walker (2015).
## Fitting Linear Mixed-Effects Models Using lme4. Journal of
## Statistical Software, 67(1), 1-48. doi:10.18637/jss.v067.i01.
##
## A BibTeX entry for LaTeX users is
##
## @Article{,
## title = {Fitting Linear Mixed-Effects Models Using {lme4}},
## author = {Douglas Bates and Martin M{\"a}chler and Ben Bolker and Steve Walker},
## journal = {Journal of Statistical Software},
## year = {2015},
## volume = {67},
## number = {1},
## pages = {1--48},
## doi = {10.18637/jss.v067.i01},
## }citation("rstatix")##
## To cite package 'rstatix' in publications use:
##
## Kassambara A (2021). _rstatix: Pipe-Friendly Framework for Basic
## Statistical Tests_. R package version 0.7.0,
## <https://CRAN.R-project.org/package=rstatix>.
##
## A BibTeX entry for LaTeX users is
##
## @Manual{,
## title = {rstatix: Pipe-Friendly Framework for Basic Statistical Tests},
## author = {Alboukadel Kassambara},
## year = {2021},
## note = {R package version 0.7.0},
## url = {https://CRAN.R-project.org/package=rstatix},
## }citation("rmcorr")##
## To cite package 'rmcorr' in publications use:
##
## Bakdash J, Marusich L (2022). _rmcorr: Repeated Measures
## Correlation_. R package version 0.5.2,
## <https://CRAN.R-project.org/package=rmcorr>.
##
## A BibTeX entry for LaTeX users is
##
## @Manual{,
## title = {rmcorr: Repeated Measures Correlation},
## author = {Jonathan Z. Bakdash and Laura R. Marusich},
## year = {2022},
## note = {R package version 0.5.2},
## url = {https://CRAN.R-project.org/package=rmcorr},
## }citation("ggplot2")##
## To cite ggplot2 in publications, please use:
##
## H. Wickham. ggplot2: Elegant Graphics for Data Analysis.
## Springer-Verlag New York, 2016.
##
## A BibTeX entry for LaTeX users is
##
## @Book{,
## author = {Hadley Wickham},
## title = {ggplot2: Elegant Graphics for Data Analysis},
## publisher = {Springer-Verlag New York},
## year = {2016},
## isbn = {978-3-319-24277-4},
## url = {https://ggplot2.tidyverse.org},
## }citation("ggpubr")##
## To cite package 'ggpubr' in publications use:
##
## Kassambara A (2020). _ggpubr: 'ggplot2' Based Publication Ready
## Plots_. R package version 0.4.0,
## <https://CRAN.R-project.org/package=ggpubr>.
##
## A BibTeX entry for LaTeX users is
##
## @Manual{,
## title = {ggpubr: 'ggplot2' Based Publication Ready Plots},
## author = {Alboukadel Kassambara},
## year = {2020},
## note = {R package version 0.4.0},
## url = {https://CRAN.R-project.org/package=ggpubr},
## }3.1 Characterize Participant Sample
Section 3.1 Participants
It is important to describe the sample upon which these findings are based.
It is especially important to examine differences in AIMS which is important for understanding state-based musical absorption and is also not described in the other paper, “Collectively Classical”.
# AIMS
df.full%>%group_by(group)%>%summarise(mean = mean(AIMS, na.rm = TRUE), sd = sd(AIMS, na.rm = TRUE))## # A tibble: 2 × 3
## group mean sd
## <fct> <dbl> <dbl>
## 1 Live 112. 26.2
## 2 Virtual 83.3 58.9AIMS: Two-sample t-test
live_aims<-df.full%>%filter(group == "Live")%>%select(AIMS)%>%na.omit() # n = 91
virtual_aims<-df.full%>%filter(group == "Virtual")%>%select(AIMS)%>%na.omit() # n = 45
# except several people in the virtual audience have 0s as their value for the AIMS scale. This is because the AIMS score is a sum. People who haven't responded at all are summing to 0 so need to remove the 0s or convert them to NAs.
virtual_aims[virtual_aims==0]<-NA
virtual_aims<-na.omit(virtual_aims) # n = 31
t.test(live_aims, virtual_aims)##
## Welch Two Sample t-test
##
## data: live_aims and virtual_aims
## t = -1.9947, df = 68.42, p-value = 0.05006
## alternative hypothesis: true difference in means is not equal to 0
## 95 percent confidence interval:
## -17.917515047 0.002591261
## sample estimates:
## mean of x mean of y
## 111.9780 120.9355## I should do this for the AIMS score in the actual dataframe as well.
test<-df.full%>%select(Pt_ID, AIMS)
df.full$AIMS[df.full$AIMS == 0]<-NA
summary(live_aims)## AIMS
## Min. : 50.0
## 1st Qu.: 93.5
## Median :113.0
## Mean :112.0
## 3rd Qu.:131.5
## Max. :160.0summary(virtual_aims)## AIMS
## Min. : 85.0
## 1st Qu.:102.0
## Median :125.0
## Mean :120.9
## 3rd Qu.:133.5
## Max. :164.0#could also test with syntax:
t.test(df.full$AIMS~df.full$group)##
## Welch Two Sample t-test
##
## data: df.full$AIMS by df.full$group
## t = -1.9947, df = 68.42, p-value = 0.05006
## alternative hypothesis: true difference in means between group Live and group Virtual is not equal to 0
## 95 percent confidence interval:
## -17.917515047 0.002591261
## sample estimates:
## mean in group Live mean in group Virtual
## 111.9780 120.93553.2.1 Internal Consistency
Reliability Estimates: describe the results of omega and alpha for the absorption scale.
Omega
Omega: Reliability measure of internal consistency. Omega represents an estimate of the general factor saturation of a test that was proposed by McDonald. Omega is the best estimate of internal consistency (Zinbarg er al., 2006).
Internal consistency or reliability refers to a measurement scale’s ability to measure a single construct in a dependable way. Internal consistency of the absorption scale was measured with Omega, which is considered the best test of reliability (McDonald, 1999; Zinbarg, Yovel, Revelle, & McDonald, 2006). Similarly to alpha, another reliability measure, values above 0.8 are considered good internal reliability. The absorption scale showed satisfactory internal consistency with an omega value of 0.79. Alpha is more influenced by the number of items in the scale, with the value of alpha improving as the number of items increases (Cronbach, 1951; Zinbarg et al., 2006). Using alpha, the absorption scale had a worse measure of consistency (0.68), which is likely because the scale is measuring more phenomena than just absorption.
Factor scores were computed based on the 4-factor analysis using the Thurstone method. These scores were used in subsequent analyses to examine the relations between the computed factors and other phenomena measured by the survey.
http://personality-project.org/r/psych/HowTo/omega.pdf
Absorption
absorption_items<-c("own_world", "absorbed_music", "daydream", "sense_time", "distracted", "attentive", "attention_others", "attention_sensations", "positively_transformed", "negatively_transformed")
df_absorption<-df.full%>%select("Pt_ID", contains(absorption_items))
df_absorb.long<-df_absorption%>%pivot_longer(!Pt_ID,
names_to = c("question", "piece"),
names_pattern ="(.*)_(.*)",
values_to = "response")
df_absorb.wide<-df_absorb.long%>%pivot_wider(names_from = question, values_from = response)
describe(df_absorb.wide)## vars n mean sd median trimmed mad min max range
## Pt_ID* 1 408 68.50 39.31 68.5 68.50 50.41 1 136 135
## piece* 2 408 2.00 0.82 2.0 2.00 1.48 1 3 2
## own_world 3 372 2.96 1.68 3.0 2.99 1.48 0 6 6
## absorbed_music 4 372 4.61 1.13 5.0 4.71 1.48 0 6 6
## daydream 5 373 2.25 1.67 2.0 2.15 1.48 0 6 6
## sense_time 6 370 3.67 1.77 4.0 3.79 1.48 0 6 6
## distracted 7 373 1.73 1.56 1.0 1.57 1.48 0 6 6
## attentive 8 372 4.05 1.32 4.0 4.12 1.48 0 6 6
## attention_others 9 367 1.31 1.32 1.0 1.12 1.48 0 5 5
## attention_sensations 10 373 2.68 1.61 3.0 2.67 1.48 0 6 6
## positively_transformed 11 373 3.67 1.60 4.0 3.80 1.48 0 6 6
## negatively_transformed 12 371 0.49 1.06 0.0 0.20 0.00 0 6 6
## skew kurtosis se
## Pt_ID* 0.00 -1.21 1.95
## piece* 0.00 -1.51 0.04
## own_world -0.06 -0.91 0.09
## absorbed_music -0.85 0.97 0.06
## daydream 0.29 -0.88 0.09
## sense_time -0.51 -0.75 0.09
## distracted 0.75 -0.13 0.08
## attentive -0.44 -0.39 0.07
## attention_others 0.93 0.04 0.07
## attention_sensations 0.06 -0.92 0.08
## positively_transformed -0.69 -0.15 0.08
## negatively_transformed 2.51 6.25 0.06df_absorb<-df_absorb.wide%>%select(contains(absorption_items))
lowerCor(df_absorb)## own_w absr_ dydrm sns_t dstrc attnt attntn_t attntn_s
## own_world 1.00
## absorbed_music 0.02 1.00
## daydream 0.50 -0.13 1.00
## sense_time 0.09 0.50 0.14 1.00
## distracted 0.25 -0.36 0.45 -0.19 1.00
## attentive -0.16 0.64 -0.34 0.36 -0.61 1.00
## attention_others -0.08 -0.02 0.12 -0.05 0.17 -0.11 1.00
## attention_sensations 0.23 0.01 0.29 0.04 0.31 -0.12 0.23 1.00
## positively_transformed -0.02 0.47 0.13 0.32 -0.10 0.31 0.13 0.12
## negatively_transformed 0.05 -0.26 0.06 -0.09 0.18 -0.22 0.06 0.03
## pstv_ ngtv_
## own_world
## absorbed_music
## daydream
## sense_time
## distracted
## attentive
## attention_others
## attention_sensations
## positively_transformed 1.00
## negatively_transformed -0.29 1.00vector <-c(-1,1,-1,1,-1,1,-1,-1,1,-1) # assumes negative loading of absorbed in own world, distracted, daydream, attention others, attention sensations, negatively transformed
om<-omega(df_absorb,key = vector) # when key vector is provided omega is 0.78; when key vector is not provided, omega total = .74
om## Omega
## Call: omegah(m = m, nfactors = nfactors, fm = fm, key = key, flip = flip,
## digits = digits, title = title, sl = sl, labels = labels,
## plot = plot, n.obs = n.obs, rotate = rotate, Phi = Phi, option = option,
## covar = covar)
## Alpha: 0.68
## G.6: 0.75
## Omega Hierarchical: 0.23
## Omega H asymptotic: 0.29
## Omega Total 0.79
##
## Schmid Leiman Factor loadings greater than 0.2
## g F1* F2* F3* h2 u2 p2
## own_world- 0.46 0.54 0.54 0.46 0.40
## absorbed_music 0.83 0.70 0.30 0.02
## daydream- 0.59 0.47 0.61 0.39 0.57
## sense_time 0.55 0.34 0.66 0.01
## distracted- 0.48 0.44 0.21 0.33 0.58 0.42 0.40
## attentive 0.36 0.73 0.69 0.31 0.18
## attention_others- 0.43 0.22 0.78 0.07
## attention_sensations- 0.32 0.33 0.24 0.76 0.44
## positively_transformed 0.57 -0.37 0.47 0.53 0.01
## negatively_transformed- 0.31 0.11 0.89 0.06
##
## With eigenvalues of:
## g F1* F2* F3*
## 1.07 2.15 0.64 0.64
##
## general/max 0.5 max/min = 3.38
## mean percent general = 0.22 with sd = 0.21 and cv of 0.99
## Explained Common Variance of the general factor = 0.24
##
## The degrees of freedom are 18 and the fit is 0.17
## The number of observations was 408 with Chi Square = 67.94 with prob < 1e-07
## The root mean square of the residuals is 0.03
## The df corrected root mean square of the residuals is 0.05
## RMSEA index = 0.082 and the 10 % confidence intervals are 0.062 0.104
## BIC = -40.26
##
## Compare this with the adequacy of just a general factor and no group factors
## The degrees of freedom for just the general factor are 35 and the fit is 1.89
## The number of observations was 408 with Chi Square = 760.13 with prob < 3.9e-137
## The root mean square of the residuals is 0.21
## The df corrected root mean square of the residuals is 0.24
##
## RMSEA index = 0.225 and the 10 % confidence intervals are 0.212 0.24
## BIC = 549.73
##
## Measures of factor score adequacy
## g F1* F2* F3*
## Correlation of scores with factors 0.68 0.91 0.61 0.68
## Multiple R square of scores with factors 0.46 0.83 0.37 0.47
## Minimum correlation of factor score estimates -0.08 0.66 -0.25 -0.07
##
## Total, General and Subset omega for each subset
## g F1* F2* F3*
## Omega total for total scores and subscales 0.79 0.80 0.71 0.32
## Omega general for total scores and subscales 0.23 0.05 0.37 0.08
## Omega group for total scores and subscales 0.52 0.75 0.34 0.24om$key## [1] -1 1 -1 1 -1 1 -1 -1 1 -1summary(om)## Omega
## omega(m = df_absorb, key = vector)
## Alpha: 0.68
## G.6: 0.75
## Omega Hierarchical: 0.23
## Omega H asymptotic: 0.29
## Omega Total 0.79
##
## With eigenvalues of:
## g F1* F2* F3*
## 1.07 2.15 0.64 0.64
## The degrees of freedom for the model is 18 and the fit was 0.17
## The number of observations was 408 with Chi Square = 67.94 with prob < 0
##
## The root mean square of the residuals is 0.03
## The df corrected root mean square of the residuals is 0.07
##
## RMSEA and the 0.9 confidence intervals are 0.082 0.062 0.104
## BIC = -40.26Explained Common Variance of the general factor = 0.24
##
## Total, General and Subset omega for each subset
## g F1* F2* F3*
## Omega total for total scores and subscales 0.79 0.80 0.71 0.32
## Omega general for total scores and subscales 0.23 0.05 0.37 0.08
## Omega group for total scores and subscales 0.52 0.75 0.34 0.24Kama Muta
Check how the value of omega for the absorption scale compares to established scales like KM and AWE. Omega is higher for KM and AWE.
df_KM<-df.full%>%
select(Pt_ID, tears_Beethoven:positive_Beethoven, moved_Beethoven:touched_Beethoven, KM_Beethoven, tears_Schnittke:positive_Schnittke, moved_Schnittke:touched_Schnittke,
KM_Schnittke, tears_Folk:positive_Folk, moved_Folk:touched_Folk, KM_Folk)
df_KM.long<-df_KM%>%pivot_longer(!Pt_ID,
names_to = c("question", "piece"),
names_pattern ="(.*)_(.*)",
values_to = "response")
df_KM.wide<-df_KM.long%>%pivot_wider(names_from = question, values_from = response)df_kamamuta<-df_KM.wide%>%select(-Pt_ID, -piece)
lowerCor(df_kamamuta)## tears chlls wrm_f chkd_ rfrsh wlcmn clsns postv moved tochd KM
## tears 1.00
## chills 0.47 1.00
## warm_feeling 0.42 0.33 1.00
## choked_up 0.60 0.43 0.37 1.00
## refreshed 0.24 0.27 0.41 0.22 1.00
## welcoming 0.33 0.32 0.57 0.28 0.54 1.00
## closeness 0.34 0.35 0.58 0.27 0.51 0.75 1.00
## positive 0.25 0.24 0.36 0.21 0.68 0.55 0.49 1.00
## moved 0.38 0.39 0.40 0.35 0.47 0.44 0.47 0.51 1.00
## touched 0.42 0.40 0.37 0.40 0.42 0.41 0.40 0.43 0.72 1.00
## KM 0.63 0.61 0.71 0.58 0.69 0.76 0.76 0.67 0.74 0.73 1.00df_kamamuta_items<-df_kamamuta%>%select(-KM)
omega(df_kamamuta_items)
## Omega
## Call: omegah(m = m, nfactors = nfactors, fm = fm, key = key, flip = flip,
## digits = digits, title = title, sl = sl, labels = labels,
## plot = plot, n.obs = n.obs, rotate = rotate, Phi = Phi, option = option,
## covar = covar)
## Alpha: 0.88
## G.6: 0.9
## Omega Hierarchical: 0.67
## Omega H asymptotic: 0.74
## Omega Total 0.91
##
## Schmid Leiman Factor loadings greater than 0.2
## g F1* F2* F3* h2 u2 p2
## tears 0.47 0.63 0.63 0.37 0.35
## chills 0.44 0.39 0.36 0.64 0.54
## warm_feeling 0.50 0.43 0.25 0.49 0.51 0.50
## choked_up 0.43 0.59 0.53 0.47 0.34
## refreshed 0.60 0.36 0.20 0.55 0.45 0.66
## welcoming 0.59 0.64 0.76 0.24 0.46
## closeness 0.58 0.59 0.69 0.31 0.49
## positive 0.61 0.32 0.23 0.57 0.43 0.66
## moved 0.74 0.40 0.71 0.29 0.76
## touched 0.69 0.38 0.65 0.35 0.74
##
## With eigenvalues of:
## g F1* F2* F3*
## 3.30 1.18 1.04 0.41
##
## general/max 2.8 max/min = 2.86
## mean percent general = 0.55 with sd = 0.15 and cv of 0.27
## Explained Common Variance of the general factor = 0.56
##
## The degrees of freedom are 18 and the fit is 0.25
## The number of observations was 408 with Chi Square = 99.53 with prob < 2.7e-13
## The root mean square of the residuals is 0.03
## The df corrected root mean square of the residuals is 0.05
## RMSEA index = 0.105 and the 10 % confidence intervals are 0.086 0.126
## BIC = -8.68
##
## Compare this with the adequacy of just a general factor and no group factors
## The degrees of freedom for just the general factor are 35 and the fit is 1.51
## The number of observations was 408 with Chi Square = 608.55 with prob < 8.3e-106
## The root mean square of the residuals is 0.15
## The df corrected root mean square of the residuals is 0.17
##
## RMSEA index = 0.2 and the 10 % confidence intervals are 0.187 0.215
## BIC = 398.16
##
## Measures of factor score adequacy
## g F1* F2* F3*
## Correlation of scores with factors 0.85 0.78 0.80 0.53
## Multiple R square of scores with factors 0.73 0.61 0.65 0.28
## Minimum correlation of factor score estimates 0.45 0.22 0.29 -0.44
##
## Total, General and Subset omega for each subset
## g F1* F2* F3*
## Omega total for total scores and subscales 0.91 0.87 0.73 0.77
## Omega general for total scores and subscales 0.67 0.52 0.30 0.59
## Omega group for total scores and subscales 0.18 0.34 0.43 0.18Awe
awe_items<-c("presence_grand", "greater_than_myself", "jaw_drop", "gasped", "challenge_process", "hard_comprehend", "AWE")
df_awe<-df.full%>%select(Pt_ID, contains(awe_items))
df_awe.long<-df_awe%>%pivot_longer(!Pt_ID,
names_to = c("question", "piece"),
names_pattern ="(.*)_(.*)",
values_to = "response")
df_awe.wide<-df_awe.long%>%pivot_wider(names_from = question, values_from = response)df_Aw<-df_awe.wide%>%select(-Pt_ID, -piece)
lowerCor(df_Aw)## prsn_ grt__ jw_dr gaspd chll_ hrd_c AWE AWE_w
## presence_grand 1.00
## greater_than_myself 0.73 1.00
## jaw_drop 0.35 0.32 1.00
## gasped 0.31 0.25 0.56 1.00
## challenge_process 0.27 0.22 0.19 0.15 1.00
## hard_comprehend 0.27 0.26 0.17 0.19 0.48 1.00
## AWE 0.73 0.69 0.65 0.62 0.61 0.62 1.00
## AWE_wonder 0.77 0.73 0.63 0.60 0.57 0.58 0.98 1.00df_awe_items<-df_Aw%>%select(-AWE)
omega(df_awe_items)## Warning in fa.stats(r = r, f = f, phi = phi, n.obs = n.obs, np.obs = np.obs, :
## The estimated weights for the factor scores are probably incorrect. Try a
## different factor score estimation method.## Warning in fac(r = r, nfactors = nfactors, n.obs = n.obs, rotate = rotate, : An
## ultra-Heywood case was detected. Examine the results carefully
## Omega
## Call: omegah(m = m, nfactors = nfactors, fm = fm, key = key, flip = flip,
## digits = digits, title = title, sl = sl, labels = labels,
## plot = plot, n.obs = n.obs, rotate = rotate, Phi = Phi, option = option,
## covar = covar)
## Alpha: 0.83
## G.6: 0.93
## Omega Hierarchical: 0.68
## Omega H asymptotic: 0.75
## Omega Total 0.9
##
## Schmid Leiman Factor loadings greater than 0.2
## g F1* F2* F3* h2 u2 p2
## presence_grand 0.67 0.54 0.74 0.26 0.61
## greater_than_myself 0.64 0.57 0.74 0.26 0.55
## jaw_drop 0.51 0.54 0.54 0.46 0.47
## gasped 0.48 0.61 0.61 0.39 0.38
## challenge_process 0.42 0.57 0.51 0.49 0.35
## hard_comprehend 0.43 0.54 0.48 0.52 0.39
## AWE_wonder 0.89 0.27 0.29 0.33 1.06 -0.06 0.75
##
## With eigenvalues of:
## g F1* F2* F3*
## 2.52 0.69 0.75 0.73
##
## general/max 3.37 max/min = 1.08
## mean percent general = 0.5 with sd = 0.15 and cv of 0.29
## Explained Common Variance of the general factor = 0.54
##
## The degrees of freedom are 3 and the fit is 0.53
## The number of observations was 408 with Chi Square = 211.36 with prob < 1.5e-45
## The root mean square of the residuals is 0.01
## The df corrected root mean square of the residuals is 0.04
## RMSEA index = 0.413 and the 10 % confidence intervals are 0.367 0.461
## BIC = 193.32
##
## Compare this with the adequacy of just a general factor and no group factors
## The degrees of freedom for just the general factor are 14 and the fit is 2.53
## The number of observations was 408 with Chi Square = 1019.32 with prob < 1.1e-208
## The root mean square of the residuals is 0.15
## The df corrected root mean square of the residuals is 0.19
##
## RMSEA index = 0.42 and the 10 % confidence intervals are 0.398 0.442
## BIC = 935.16
##
## Measures of factor score adequacy
## g F1* F2* F3*
## Correlation of scores with factors 0.98 0.69 0.77 0.87
## Multiple R square of scores with factors 0.96 0.48 0.59 0.75
## Minimum correlation of factor score estimates 0.93 -0.05 0.18 0.50
##
## Total, General and Subset omega for each subset
## g F1* F2* F3*
## Omega total for total scores and subscales 0.90 0.85 0.73 0.82
## Omega general for total scores and subscales 0.68 0.50 0.31 0.49
## Omega group for total scores and subscales 0.19 0.36 0.42 0.33Alpha
Alpha is another form of reliability, however as the number of items in the scale increases, so does Alpha, making it a poor measure of internal reliability when the scales have a large number of items.
psych::alpha(df_absorb) #score all of the items as part of one scale.## Warning in psych::alpha(df_absorb): Some items were negatively correlated with the total scale and probably
## should be reversed.
## To do this, run the function again with the 'check.keys=TRUE' option## Some items ( own_world daydream distracted attention_others attention_sensations negatively_transformed ) were negatively correlated with the total scale and
## probably should be reversed.
## To do this, run the function again with the 'check.keys=TRUE' option##
## Reliability analysis
## Call: psych::alpha(x = df_absorb)
##
## raw_alpha std.alpha G6(smc) average_r S/N ase mean sd median_r
## 0.47 0.42 0.59 0.068 0.73 0.039 2.7 0.62 0.056
##
## 95% confidence boundaries
## lower alpha upper
## Feldt 0.38 0.47 0.54
## Duhachek 0.39 0.47 0.54
##
## Reliability if an item is dropped:
## raw_alpha std.alpha G6(smc) average_r S/N alpha se
## own_world 0.41 0.36 0.55 0.060 0.57 0.043
## absorbed_music 0.43 0.37 0.52 0.061 0.58 0.041
## daydream 0.36 0.33 0.50 0.051 0.48 0.047
## sense_time 0.40 0.34 0.54 0.054 0.51 0.043
## distracted 0.48 0.44 0.59 0.082 0.80 0.038
## attentive 0.52 0.48 0.59 0.092 0.91 0.035
## attention_others 0.46 0.41 0.60 0.072 0.70 0.039
## attention_sensations 0.38 0.34 0.55 0.053 0.50 0.045
## positively_transformed 0.40 0.35 0.54 0.055 0.53 0.043
## negatively_transformed 0.51 0.50 0.65 0.098 0.98 0.037
## var.r med.r
## own_world 0.073 0.059
## absorbed_music 0.054 0.076
## daydream 0.065 0.032
## sense_time 0.070 0.055
## distracted 0.054 0.055
## attentive 0.045 0.076
## attention_others 0.079 0.055
## attention_sensations 0.077 0.055
## positively_transformed 0.070 0.045
## negatively_transformed 0.072 0.120
##
## Item statistics
## n raw.r std.r r.cor r.drop mean sd
## own_world 372 0.510 0.47 0.39 0.273 2.96 1.7
## absorbed_music 372 0.420 0.47 0.46 0.249 4.61 1.1
## daydream 373 0.606 0.55 0.54 0.389 2.25 1.7
## sense_time 370 0.534 0.53 0.46 0.282 3.67 1.8
## distracted 373 0.315 0.28 0.19 0.066 1.73 1.6
## attentive 372 0.136 0.19 0.11 -0.080 4.05 1.3
## attention_others 367 0.327 0.36 0.18 0.120 1.31 1.3
## attention_sensations 373 0.551 0.53 0.43 0.331 2.68 1.6
## positively_transformed 373 0.515 0.51 0.45 0.284 3.67 1.6
## negatively_transformed 371 0.073 0.13 -0.12 -0.101 0.49 1.1
##
## Non missing response frequency for each item
## 0 1 2 3 4 5 6 miss
## own_world 0.09 0.13 0.18 0.20 0.20 0.15 0.06 0.09
## absorbed_music 0.01 0.01 0.03 0.10 0.27 0.35 0.23 0.09
## daydream 0.19 0.18 0.18 0.20 0.14 0.08 0.03 0.09
## sense_time 0.06 0.09 0.11 0.15 0.19 0.24 0.15 0.09
## distracted 0.27 0.25 0.19 0.15 0.08 0.03 0.02 0.09
## attentive 0.00 0.03 0.10 0.17 0.28 0.27 0.13 0.09
## attention_others 0.33 0.33 0.15 0.10 0.07 0.02 0.00 0.10
## attention_sensations 0.09 0.20 0.16 0.20 0.22 0.09 0.03 0.09
## positively_transformed 0.07 0.05 0.09 0.20 0.24 0.26 0.09 0.09
## negatively_transformed 0.75 0.13 0.02 0.06 0.02 0.00 0.01 0.09# running this without the key indicated "Some items (own_world daydream distracted attention_others attention_sensations negatively_transformed) were negatively correlated with the total scale.
## Earlier I used my intuitions of the questions to choose which would be less related to being absorbed in the music/what we want to measure with absorption and these are the same items that were flagged as negative now
# vector <-c(-1,1,-1,1,-1,1,-1,-1,1,-1) # assumes negative loading of absorbed in own world, distracted, daydream, attention others, attention sensations, negatively transformed. This is exactly what I expected but it is good that this confirms the intuitions around the questions.
## Re-run with checking the sign of the correlation
alpha(df_absorb, check.keys = TRUE)## Warning in alpha(df_absorb, check.keys = TRUE): Some items were negatively correlated with total scale and were automatically reversed.
## This is indicated by a negative sign for the variable name.##
## Reliability analysis
## Call: alpha(x = df_absorb, check.keys = TRUE)
##
## raw_alpha std.alpha G6(smc) average_r S/N ase mean sd median_r
## 0.66 0.68 0.75 0.17 2.1 0.025 4.1 0.74 0.16
##
## 95% confidence boundaries
## lower alpha upper
## Feldt 0.61 0.66 0.71
## Duhachek 0.61 0.66 0.71
##
## Reliability if an item is dropped:
## raw_alpha std.alpha G6(smc) average_r S/N alpha se
## own_world- 0.66 0.68 0.73 0.19 2.1 0.025
## absorbed_music 0.61 0.62 0.68 0.15 1.6 0.029
## daydream- 0.63 0.65 0.71 0.17 1.9 0.027
## sense_time 0.66 0.67 0.73 0.18 2.0 0.025
## distracted- 0.58 0.60 0.68 0.14 1.5 0.032
## attentive 0.58 0.59 0.66 0.14 1.4 0.032
## attention_others- 0.67 0.70 0.76 0.20 2.3 0.025
## attention_sensations- 0.66 0.68 0.74 0.19 2.1 0.025
## positively_transformed 0.66 0.67 0.73 0.19 2.1 0.025
## negatively_transformed- 0.65 0.67 0.74 0.18 2.0 0.026
## var.r med.r
## own_world- 0.040 0.17
## absorbed_music 0.034 0.14
## daydream- 0.038 0.16
## sense_time 0.039 0.16
## distracted- 0.040 0.12
## attentive 0.035 0.11
## attention_others- 0.043 0.20
## attention_sensations- 0.043 0.16
## positively_transformed 0.037 0.16
## negatively_transformed- 0.047 0.16
##
## Item statistics
## n raw.r std.r r.cor r.drop mean sd
## own_world- 372 0.44 0.40 0.31 0.24 3.0 1.7
## absorbed_music 372 0.62 0.66 0.66 0.52 4.6 1.1
## daydream- 373 0.55 0.52 0.48 0.36 3.8 1.7
## sense_time 370 0.45 0.44 0.35 0.23 3.7 1.8
## distracted- 373 0.72 0.71 0.70 0.59 4.3 1.6
## attentive 372 0.74 0.76 0.79 0.65 4.1 1.3
## attention_others- 367 0.29 0.30 0.15 0.11 4.7 1.3
## attention_sensations- 373 0.43 0.40 0.28 0.23 3.3 1.6
## positively_transformed 373 0.41 0.42 0.33 0.21 3.7 1.6
## negatively_transformed- 371 0.39 0.44 0.31 0.25 5.5 1.1
##
## Non missing response frequency for each item
## 0 1 2 3 4 5 6 miss
## own_world 0.09 0.13 0.18 0.20 0.20 0.15 0.06 0.09
## absorbed_music 0.01 0.01 0.03 0.10 0.27 0.35 0.23 0.09
## daydream 0.19 0.18 0.18 0.20 0.14 0.08 0.03 0.09
## sense_time 0.06 0.09 0.11 0.15 0.19 0.24 0.15 0.09
## distracted 0.27 0.25 0.19 0.15 0.08 0.03 0.02 0.09
## attentive 0.00 0.03 0.10 0.17 0.28 0.27 0.13 0.09
## attention_others 0.33 0.33 0.15 0.10 0.07 0.02 0.00 0.10
## attention_sensations 0.09 0.20 0.16 0.20 0.22 0.09 0.03 0.09
## positively_transformed 0.07 0.05 0.09 0.20 0.24 0.26 0.09 0.09
## negatively_transformed 0.75 0.13 0.02 0.06 0.02 0.00 0.01 0.09# Alpha is quite low which indicates that the scale is measuring more than just one phenomenon (as expected, this is not just measuring absorption)
## Make key (based on discussion with Remy)
key.list<-list(all = c(-1,2,-3,4,-5,6,-7,-8,9,-10), absorbed = c(2,4),attention=c(-5, 6, -7), mindwandering = c(-1, -3, -8), affect = c(9, 10)) # note that I have not reversed the negatively_transformed item in the affect list however it is reversed in the list for all because the correlation for this item is actually reversed despite the hypotheses on its relation to affect. But perhaps the affect subscale is more measuring positive affect because those reporting high positive transformation would report lower negative transformation and vice versa.
myKeys <- make.keys(nvars=10, key.list, item.labels = colnames(df_absorb))
my.scores <- scoreItems(myKeys,df_absorb) # form several scales## Warning in sqrt(diag(1/corrected.var)): NaNs produced## Warning in sqrt(Q/n.subjects): NaNs produced## Warning in sqrt(y[i] * y[j]): NaNs produced
## Warning in sqrt(y[i] * y[j]): NaNs produced
## Warning in sqrt(y[i] * y[j]): NaNs produced
## Warning in sqrt(y[i] * y[j]): NaNs producedmy.scores # show the highlights of the results## Call: scoreItems(keys = myKeys, items = df_absorb)
##
## (Unstandardized) Alpha:
## all absorbed attention mindwandering affect
## alpha 0.66 0.62 0.56 0.61 -0.76
##
## Standard errors of unstandardized Alpha:
## all absorbed attention mindwandering affect
## ASE 0.031 0.077 0.058 0.057 NaN
##
## Average item correlation:
## all absorbed attention mindwandering affect
## average.r 0.16 0.45 0.3 0.34 -0.27
##
## Median item correlation:
## all absorbed attention mindwandering affect
## 0.16 0.50 0.17 0.29 -0.30
##
## Guttman 6* reliability:
## all absorbed attention mindwandering affect
## Lambda.6 0.74 0.58 0.62 0.6 -0.0033
##
## Signal/Noise based upon av.r :
## all absorbed attention mindwandering affect
## Signal/Noise 2 1.6 1.3 1.6 -0.43
##
## Scale intercorrelations corrected for attenuation
## raw correlations below the diagonal, alpha on the diagonal
## corrected correlations above the diagonal:
## all absorbed attention mindwandering affect
## all 0.66 0.929 1.323 0.99 NaN
## absorbed 0.60 0.623 0.676 -0.10 NaN
## attention 0.81 0.401 0.565 0.66 NaN
## mindwandering 0.63 -0.064 0.390 0.61 NaN
## affect 0.15 0.301 -0.013 -0.14 -0.76
##
## In order to see the item by scale loadings and frequency counts of the data
## print with the short option = FALSEReduce Dimensionality
Section 5.1 in Psych package Dimension reduction through factor analysis, PCA, and cluster analysis:
“The typical data matrix represents multiple items or scales usually thought to reflect fewer underlying constructs. At the most simple, a set of items can be be thought to represent a random sample from one underlying domain or perhaps a small set of domains. The question for the psychometrician is how many domains are represented and how well does each item represent the domains. Solutions to this problem are examples of factor analysis (FA), principal components analysis (PCA), and cluster analysis (CA). All of these procedures aim to reduce the complexity of the observed data. In the case of FA, the goal is to identify fewer underlying constructs to explain the observed data. In the case of PCA, the goal can be mere data reduction, but the interpretation of components is frequently done in terms similar to those used when describing the latent variables estimated by FA. Cluster analytic techniques, although usually used to partition the subject space rather than the variable space, can also be used to group variables to reduce the complexity of the data by forming fewer and more homogeneous sets of tests or items.”
From: http://personality-project.org/r/psych/HowTo/factor.pdf ## Hypotheses To me, this corplot indicates that absorption in the music and attention to the music are part of the same factor along with the loss of sense of time.
png('absorption_corplot.png')
cor.plot(df_absorb, numbers = TRUE)
dev.off()## png
## 2I asked the philosophers to describe their hypotheses: For each item answer the questions 1) Which phenomenon would this most represent (absorption, mind-wandering, attention, or affect?) and 2) if participants reported a high value on the scale, would that be a high or low amount of that phenomenon?’
Remy
The scale measures 4 phenomena: i) absorption, ii) mind wandering,
iii) attention, and iv) affect.
absorbed in your own_world: more is related to more mind wandering
(inward attention)
absorbed_music: absorption (outward attention)
daydream: lower attention more mind-wandering
loss of sense of time: more absorption distraction: decreased attention
and more mind wandering
attentive: increased attention attention to others - no hypotheses
attention to physical sensations - no hypotheses
positively and negatively transformed: affective
Nanette
own_world: Absorption, high value = high amount
absorbed_music: Absorption, high value = high amount
daydream: Absorption and mind-wandering, high value = high amount
lose your sense of time: Absorption and mind-wandering, high value =
high amount
distracted: Attention, high value = highly distracted (so: not
attentive, not mind-wandering, not absorbed)
attentive to the music: Attention, high value = highly attentive
attention_others: Attention, high value = highly attentive (so: not
mind-wandering, not absorbed)
attention to yourself and your physical sensations: Attention, high
value = highly attentive
positively transformed by the music: Affect: sense of self, high value =
high amount of affect
negatively transformed by the music: Affect: sense of self, high value =
high amount of affect
Simon
Absorption: (scoring high indicated high amount) To what extent were you absorbed in your own world? To what extent were you absorbed by the music? To what extent did you lose your sense of time?
Mind wandering: (scoring high indicated high amount) To what extent did you daydream? To what extent were you distracted by thoughts or worries of a personal nature?
Attention: (scoring high indicated high amount) To what extent were you attentive to the music without distracting thoughts, memories or fantasies?
Affect: (scoring high indicated high amount) To what extent do you feel positively transformed by the music? To what extent do you feel negatively transformed by the music?
Explore the data
Histograms of each of the variables
These are included in Table 1: Absorption Scale
## changing the labeling messed up later things so do this "carefully"
#df_absorb.wide$piece<-factor(df_absorb.wide$piece, levels = c("Beethoven", "Schnittke", "Folk"), labels = c("B", "S","F"))
# own world
df_absorb.wide%>%select(piece, own_world)%>%drop_na()%>%
ggplot(aes(x=own_world))+
geom_bar(stat="count")+
theme_minimal()+
theme(axis.text.x=element_blank(),
axis.text.y=element_blank())+
labs(x = "", y = "")+
facet_grid(cols = vars(piece))
graphname<-paste0("../plots/hist_own_world.png")
ggsave(graphname,width = 4, height = 3, units = 'cm')
# absorbed music
df_absorb.wide%>%select(piece, absorbed_music)%>%drop_na()%>%
ggplot(aes(x=absorbed_music))+
geom_bar(stat="count")+
theme_minimal()+
theme(axis.text.x=element_blank(),
axis.text.y=element_blank())+
labs(x = "", y = "")+
facet_grid(cols = vars(piece))
graphname<-paste0("../plots/hist_absorbed_music.png")
ggsave(graphname,width = 4, height = 3, units = 'cm')
# daydream
df_absorb.wide%>%select(piece, daydream)%>%drop_na()%>%
ggplot(aes(x=daydream))+
geom_bar(stat="count")+
theme_minimal()+
theme(axis.text.x=element_blank(),
axis.text.y=element_blank())+
labs(x = "", y = "")+
facet_grid(cols = vars(piece))
graphname<-paste0("../plots/hist_daydream.png")
ggsave(graphname,width = 4, height = 3, units = 'cm')
# sense time
df_absorb.wide%>%select(piece, sense_time)%>%drop_na()%>%
ggplot(aes(x=sense_time))+
geom_bar(stat="count")+
theme_minimal()+
theme(axis.text.x=element_blank(),
axis.text.y=element_blank())+
labs(x = "", y = "")+
facet_grid(cols = vars(piece))
graphname<-paste0("../plots/hist_sensetime.png")
ggsave(graphname,width = 4, height = 3, units = 'cm')
# distracted
df_absorb.wide%>%select(piece, distracted)%>%drop_na()%>%
ggplot(aes(x=distracted))+
geom_bar(stat="count")+
theme_minimal()+
theme(axis.text.x=element_blank(),
axis.text.y=element_blank())+
labs(x = "", y = "")+
facet_grid(cols = vars(piece))
graphname<-paste0("../plots/hist_distracted.png")
ggsave(graphname,width = 4, height = 3, units = 'cm')
# attentive
df_absorb.wide%>%select(piece, attentive)%>%drop_na()%>%
ggplot(aes(x=attentive))+
geom_bar(stat="count")+
theme_minimal()+
theme(axis.text.x=element_blank(),
axis.text.y=element_blank())+
labs(x = "", y = "")+
facet_grid(cols = vars(piece))
graphname<-paste0("../plots/hist_attentive.png")
ggsave(graphname,width = 4, height = 3, units = 'cm')
# attention others
df_absorb.wide%>%select(piece, attention_others)%>%drop_na()%>%
ggplot(aes(x=attention_others))+
geom_bar(stat="count")+
theme_minimal()+
theme(axis.text.x=element_blank(),
axis.text.y=element_blank())+
labs(x = "", y = "")+
facet_grid(cols = vars(piece))
graphname<-paste0("../plots/hist_attention_others.png")
ggsave(graphname,width = 4, height = 3, units = 'cm')
# attention sensations
df_absorb.wide%>%select(piece, attention_sensations)%>%drop_na()%>%
ggplot(aes(x=attention_sensations))+
geom_bar(stat="count")+
theme_minimal()+
theme(axis.text.x=element_blank(),
axis.text.y=element_blank())+
labs(x = "", y = "")+
facet_grid(cols = vars(piece))
graphname<-paste0("../plots/hist_attention_sensations.png")
ggsave(graphname,width = 4, height = 3, units = 'cm')
# positive transformation
df_absorb.wide%>%select(piece, positively_transformed)%>%drop_na()%>%
ggplot(aes(x=positively_transformed))+
geom_bar(stat="count")+
theme_minimal()+
theme(axis.text.x=element_blank(),
axis.text.y=element_blank())+
labs(x = "", y = "")+
facet_grid(cols = vars(piece))
graphname<-paste0("../plots/hist_pos_transform.png")
ggsave(graphname,width = 4, height = 3, units = 'cm')
# negative transformation
df_absorb.wide%>%select(piece, negatively_transformed)%>%drop_na()%>%
ggplot(aes(x=negatively_transformed))+
geom_bar(stat="count")+
theme_minimal()+
theme(axis.text.x=element_blank(),
axis.text.y=element_blank())+
labs(x = "", y = "")+
facet_grid(cols = vars(piece))
graphname<-paste0("../plots/hist_neg_transform.png")
ggsave(graphname,width = 4, height = 3, units = 'cm')
## Go back to original labelling
#df_absorb.wide$piece<-factor(df_absorb.wide$piece, levels = c("B", "S", "F"), labels = c("Beethoven", "Schnittke","Folk"))Correlations between absorption scale items and positive and negative affect by piece.
This is located in the supplementary material in S4 and supplementary figure 2.
items<-c("positive", "negative", "own_world", "absorbed_music", "daydream", "sense_time", "distracted", "attentive", "attention_others", "attention_sensations", "positively_transformed", "negatively_transformed")
df<-df.full%>%select("Pt_ID", contains(items))%>%select(-contains("Positive_Affect"))
df.long<-df%>%pivot_longer(!Pt_ID,
names_to = c("question", "piece"),
names_pattern ="(.*)_(.*)",
values_to = "response")
df.wide<-df.long%>%pivot_wider(names_from = question, values_from = response)
Beethoven<-df.wide%>%filter(piece == "Beethoven")
Schnittke<-df.wide%>%filter(piece == "Schnittke")
Folk<-df.wide%>%filter(piece == "Folk")
colours_DSQ<-c("#2d769a", "white","#b34036")
corData<-Beethoven%>%select(-Pt_ID, -piece)
corData<-na.omit(corData)
samples = nrow(corData)
title = "Beethoven"
subtitle = paste0("Kendall Correlations (BH adj) (n = ", samples, ")")
chart.correlation(corData, colours_DSQ, title, subtitle)
# check the p-values
correlation = adj.cor(corData, p.adjust = TRUE, p.adjust.method = "BH", threshold = 0.05, cor.method = "kendall")
corData<-Schnittke%>%select(-Pt_ID, -piece)
corData<-na.omit(corData)
samples = nrow(corData)
title = "Schnittke"
subtitle = paste0("Kendall Correlations (BH adj) (n = ", samples, ")")
chart.correlation(corData, colours_DSQ, title, subtitle)
# check the p-values
correlation = adj.cor(corData, p.adjust = TRUE, p.adjust.method = "BH", threshold = 0.05, cor.method = "kendall")
corData<-Folk%>%select(-Pt_ID, -piece)
corData<-na.omit(corData)
samples = nrow(corData)
title = "Folk"
subtitle = paste0("Kendall Correlations (BH adj) (n = ", samples, ")")
chart.correlation(corData, colours_DSQ, title, subtitle)
# check the p-values
correlation = adj.cor(corData, p.adjust = TRUE, p.adjust.method = "BH", threshold = 0.05, cor.method = "kendall")
graphname<-paste0("../plots/", title, "_pos_neg_correlation.png")
ggsave(graphname, width = 12, height = 10, units = 'cm', dpi = 500)3.2.2 Factor Analysis
Followed along with the tutorial here: http://personality-project.org/r/psych/HowTo/factor.pdf
pairs.panels(df_absorb)
Test for the number of factors using parallel analysis or very simple structure
fa.parallel(df_absorb) #this suggests that there are 3 factors## Warning in fa.stats(r = r, f = f, phi = phi, n.obs = n.obs, np.obs = np.obs, :
## The estimated weights for the factor scores are probably incorrect. Try a
## different factor score estimation method.
## Parallel analysis suggests that the number of factors = 3 and the number of components = 3vss(df_absorb) # this suggests that the complexity 1 solution achieves maximum at 2 factors while complexity 2 achieves maximum at 4. This may suggest that 4 factors is reasonable.
##
## Very Simple Structure
## Call: vss(x = df_absorb)
## VSS complexity 1 achieves a maximimum of 0.59 with 2 factors
## VSS complexity 2 achieves a maximimum of 0.77 with 7 factors
##
## The Velicer MAP achieves a minimum of 0.04 with 2 factors
## BIC achieves a minimum of -40.26 with 3 factors
## Sample Size adjusted BIC achieves a minimum of -0.17 with 5 factors
##
## Statistics by number of factors
## vss1 vss2 map dof chisq prob sqresid fit RMSEA BIC SABIC complex
## 1 0.48 0.00 0.055 35 4.7e+02 4.2e-78 8.4 0.48 0.175 262 373.33 1.0
## 2 0.59 0.71 0.041 26 1.4e+02 2.6e-17 4.6 0.71 0.103 -18 64.67 1.2
## 3 0.56 0.69 0.061 18 6.8e+01 1.0e-07 3.5 0.78 0.082 -40 16.85 1.5
## 4 0.57 0.77 0.092 11 4.4e+01 6.6e-06 3.0 0.82 0.086 -22 13.03 1.6
## 5 0.55 0.74 0.141 5 1.4e+01 1.5e-02 2.4 0.85 0.066 -16 -0.17 1.7
## 6 0.58 0.76 0.211 0 1.1e+00 NA 2.0 0.87 NA NA NA 1.7
## 7 0.59 0.77 0.320 -4 3.1e-07 NA 1.7 0.90 NA NA NA 1.6
## 8 0.52 0.71 0.458 -7 1.1e-08 NA 1.9 0.88 NA NA NA 1.9
## eChisq SRMR eCRMS eBIC
## 1 7.8e+02 1.5e-01 0.166 574
## 2 1.2e+02 5.8e-02 0.076 -33
## 3 4.2e+01 3.4e-02 0.053 -66
## 4 2.0e+01 2.3e-02 0.047 -46
## 5 5.2e+00 1.2e-02 0.036 -25
## 6 4.2e-01 3.4e-03 NA NA
## 7 1.0e-07 1.7e-06 NA NA
## 8 2.7e-09 2.7e-07 NA NA3 Factor Solution
This is located in the supplementary material.
absorption_factor_analysis_3<-fa(df_absorb, 3) # extract method is by default minimum residual. There are many other options though.
absorption_factor_analysis_3## Factor Analysis using method = minres
## Call: fa(r = df_absorb, nfactors = 3)
## Standardized loadings (pattern matrix) based upon correlation matrix
## MR1 MR2 MR3 h2 u2 com
## own_world 0.04 0.78 -0.18 0.54 0.46 1.1
## absorbed_music 0.85 0.06 0.06 0.70 0.30 1.0
## daydream -0.04 0.68 0.21 0.61 0.39 1.2
## sense_time 0.57 0.25 0.00 0.34 0.66 1.4
## distracted -0.45 0.29 0.37 0.58 0.42 2.7
## attentive 0.75 -0.15 -0.18 0.69 0.31 1.2
## attention_others -0.04 -0.15 0.49 0.22 0.78 1.2
## attention_sensations 0.02 0.23 0.37 0.24 0.76 1.7
## positively_transformed 0.59 0.01 0.41 0.47 0.53 1.8
## negatively_transformed -0.32 0.06 -0.07 0.11 0.89 1.2
##
## MR1 MR2 MR3
## SS loadings 2.27 1.37 0.85
## Proportion Var 0.23 0.14 0.09
## Cumulative Var 0.23 0.36 0.45
## Proportion Explained 0.50 0.31 0.19
## Cumulative Proportion 0.50 0.81 1.00
##
## With factor correlations of
## MR1 MR2 MR3
## MR1 1.00 -0.16 -0.10
## MR2 -0.16 1.00 0.32
## MR3 -0.10 0.32 1.00
##
## Mean item complexity = 1.4
## Test of the hypothesis that 3 factors are sufficient.
##
## The degrees of freedom for the null model are 45 and the objective function was 2.67 with Chi Square of 1074.64
## The degrees of freedom for the model are 18 and the objective function was 0.17
##
## The root mean square of the residuals (RMSR) is 0.03
## The df corrected root mean square of the residuals is 0.05
##
## The harmonic number of observations is 370 with the empirical chi square 37.91 with prob < 0.004
## The total number of observations was 408 with Likelihood Chi Square = 67.94 with prob < 1e-07
##
## Tucker Lewis Index of factoring reliability = 0.878
## RMSEA index = 0.082 and the 90 % confidence intervals are 0.062 0.104
## BIC = -40.26
## Fit based upon off diagonal values = 0.98
## Measures of factor score adequacy
## MR1 MR2 MR3
## Correlation of (regression) scores with factors 0.93 0.87 0.78
## Multiple R square of scores with factors 0.86 0.76 0.61
## Minimum correlation of possible factor scores 0.72 0.51 0.21plot(absorption_factor_analysis_3)
fa.diagram(absorption_factor_analysis_3)
4 Factor Solution
This is the factor solution included in the manuscript in section 3.2.2 Factor Analysis. We decided to use the 4 factor solution because we believe it represents the phenomena of interest the most, and reflects intuitions/expectations the best.
absorption_factor_analysis_4<-fa(df_absorb, 4) # extract method is by default minimum residual.
absorption_factor_analysis_4## Factor Analysis using method = minres
## Call: fa(r = df_absorb, nfactors = 4)
## Standardized loadings (pattern matrix) based upon correlation matrix
## MR1 MR2 MR3 MR4 h2 u2 com
## own_world 0.09 0.74 -0.12 -0.07 0.49 0.51 1.1
## absorbed_music 0.79 0.10 0.13 0.08 0.70 0.30 1.1
## daydream -0.16 0.69 0.13 0.08 0.63 0.37 1.2
## sense_time 0.53 0.28 0.08 0.01 0.34 0.66 1.6
## distracted -0.47 0.29 0.02 0.28 0.56 0.44 2.4
## attentive 0.81 -0.13 -0.02 -0.05 0.73 0.27 1.1
## attention_others 0.02 -0.18 0.01 0.60 0.32 0.68 1.2
## attention_sensations 0.09 0.24 -0.03 0.43 0.28 0.72 1.7
## positively_transformed 0.04 -0.02 0.87 0.00 0.79 0.21 1.0
## negatively_transformed -0.05 0.05 -0.34 0.17 0.15 0.85 1.6
##
## MR1 MR2 MR3 MR4
## SS loadings 1.92 1.35 0.99 0.72
## Proportion Var 0.19 0.13 0.10 0.07
## Cumulative Var 0.19 0.33 0.43 0.50
## Proportion Explained 0.39 0.27 0.20 0.14
## Cumulative Proportion 0.39 0.66 0.86 1.00
##
## With factor correlations of
## MR1 MR2 MR3 MR4
## MR1 1.00 -0.20 0.44 -0.27
## MR2 -0.20 1.00 0.12 0.31
## MR3 0.44 0.12 1.00 0.26
## MR4 -0.27 0.31 0.26 1.00
##
## Mean item complexity = 1.4
## Test of the hypothesis that 4 factors are sufficient.
##
## The degrees of freedom for the null model are 45 and the objective function was 2.67 with Chi Square of 1074.64
## The degrees of freedom for the model are 11 and the objective function was 0.11
##
## The root mean square of the residuals (RMSR) is 0.02
## The df corrected root mean square of the residuals is 0.05
##
## The harmonic number of observations is 370 with the empirical chi square 18.13 with prob < 0.079
## The total number of observations was 408 with Likelihood Chi Square = 44.25 with prob < 6.6e-06
##
## Tucker Lewis Index of factoring reliability = 0.867
## RMSEA index = 0.086 and the 90 % confidence intervals are 0.061 0.113
## BIC = -21.87
## Fit based upon off diagonal values = 0.99
## Measures of factor score adequacy
## MR1 MR2 MR3 MR4
## Correlation of (regression) scores with factors 0.93 0.87 0.90 0.76
## Multiple R square of scores with factors 0.86 0.75 0.81 0.58
## Minimum correlation of possible factor scores 0.72 0.51 0.62 0.15plot(absorption_factor_analysis_4)
fa.diagram(absorption_factor_analysis_4)
Compute factor scores
absorption_factor_analysis_4_scores<-factor.scores(df_absorb, absorption_factor_analysis_4)
absorbed_factors<-cbind(df_absorb.wide$Pt_ID,df_absorb.wide$piece, data.frame(absorption_factor_analysis_4_scores$scores))
colnames(absorbed_factors)<- c("Pt_ID","piece", "Absorption","Mind-wandering", "Positive_Affect", "Attention_Away") #order = 1,2,4,3 just like in the diagram.Add factors to the df.full
absorbed_factors_wide<-absorbed_factors%>%
pivot_wider(names_from = piece,
values_from = c(Absorption, `Mind-wandering`,Positive_Affect, Attention_Away))
df.full<-df.full%>%full_join(absorbed_factors_wide, by="Pt_ID")PCA
The PCA results are not included in the manuscript or in the supplementary material.
“An alternative to factor analysis, which is unfortunately frequently confused with factor analysis, is principal components analysis. Although the goals of PCA and FA are similar, PCA is a descriptive model of the data, while FA is a structural model. Psychologists typically use PCA in a manner similar to factor analysis and thus the principal function produces output that is perhaps more understandable than that produced by princomp in the stats package…
Note how the loadings from the factor model are similar but smaller than the principal component loadings. This is because the PCA model attempts to account for the entire variance of the correlation matrix, while FA accounts for just the common variance. This distinction becomes most important for small correlation matrices. Also note how the goodness of fit statistics, based upon the residual off diagonal elements, is much worse than the fa solution.”
absorption_PCA<-principal(df_absorb, rotate = "oblimin") #An oblimin rotation was employed for the principal component analysis because we have reason to believe that the components of the subscales will correlate.
absorption_PCA## Principal Components Analysis
## Call: principal(r = df_absorb, rotate = "oblimin")
## Standardized loadings (pattern matrix) based upon correlation matrix
## PC1 h2 u2 com
## own_world -0.31 0.094 0.91 1
## absorbed_music 0.76 0.578 0.42 1
## daydream -0.46 0.215 0.79 1
## sense_time 0.49 0.237 0.76 1
## distracted -0.74 0.552 0.45 1
## attentive 0.85 0.725 0.28 1
## attention_others -0.17 0.028 0.97 1
## attention_sensations -0.27 0.073 0.93 1
## positively_transformed 0.46 0.212 0.79 1
## negatively_transformed -0.40 0.162 0.84 1
##
## PC1
## SS loadings 2.88
## Proportion Var 0.29
##
## Mean item complexity = 1
## Test of the hypothesis that 1 component is sufficient.
##
## The root mean square of the residuals (RMSR) is 0.16
## with the empirical chi square 957.37 with prob < 2.6e-178
##
## Fit based upon off diagonal values = 0.62#2) Report the number of components with eigenvalues greater than 1: There are 3 transformed components with eigenvalues greater than 1 (TC1 = 2.85, TC2 = 1.98, TC3= 1.20).
cat("Eigen values\n")## Eigen valuesprint(absorption_PCA$values)## [1] 2.8763759 1.9967739 1.1842496 0.9481098 0.7440178 0.6335798 0.5593277
## [8] 0.4514446 0.3407210 0.2653998# You can also assess which components/factors to keep based on a Scree plot.
plot(absorption_PCA$values, type = "b", xlab = "Factors", ylab = "Eigen values", main="SCREE PLOT") # Keep factors before the flat line (in this case: 1, 2, and 3)
# 3) Define the number of factors and re-run based on the retained factors: We re-ran the principal component analysis based on the two retained factors.
absorption_PCA_3<-principal(df_absorb, nfactors = 3, rotate = "oblimin")
# 4) Report the amount of variance explained (cumulative): The first transformed component explained 26% of the variance, the second component explained 21% of the variance, and the third component explained 14% of the variance, therefore the cumulative variance explained was 60%.
absorption_PCA_3## Principal Components Analysis
## Call: principal(r = df_absorb, nfactors = 3, rotate = "oblimin")
## Standardized loadings (pattern matrix) based upon correlation matrix
## TC1 TC2 TC3 h2 u2 com
## own_world 0.05 0.83 -0.26 0.70 0.30 1.2
## absorbed_music 0.86 0.01 0.02 0.74 0.26 1.0
## daydream -0.02 0.82 0.12 0.72 0.28 1.0
## sense_time 0.69 0.31 -0.10 0.54 0.46 1.4
## distracted -0.46 0.49 0.31 0.66 0.34 2.7
## attentive 0.74 -0.29 -0.14 0.73 0.27 1.4
## attention_others -0.01 -0.14 0.85 0.71 0.29 1.1
## attention_sensations 0.08 0.41 0.50 0.47 0.53 2.0
## positively_transformed 0.69 0.11 0.39 0.60 0.40 1.6
## negatively_transformed -0.43 0.08 -0.10 0.20 0.80 1.2
##
## TC1 TC2 TC3
## SS loadings 2.66 2.03 1.37
## Proportion Var 0.27 0.20 0.14
## Cumulative Var 0.27 0.47 0.61
## Proportion Explained 0.44 0.33 0.23
## Cumulative Proportion 0.44 0.77 1.00
##
## With component correlations of
## TC1 TC2 TC3
## TC1 1.00 -0.10 -0.08
## TC2 -0.10 1.00 0.14
## TC3 -0.08 0.14 1.00
##
## Mean item complexity = 1.5
## Test of the hypothesis that 3 components are sufficient.
##
## The root mean square of the residuals (RMSR) is 0.09
## with the empirical chi square 306.36 with prob < 2.4e-54
##
## Fit based upon off diagonal values = 0.88- Report the items that fit into each component by setting a threshold of +/-0.4: With a cutoff threshold of 0.4, the items that load onto the first transformed component are “Absorbed in the Music” (0.85),“Lost Sense of Time”(0.70), “Positively Transformed” (0.70), and “Distracted” loaded negatively (-0.43). The items that load onto the second transformed component are “absorbed in your own world” (0.82), “Daydream” (0.82), “Distracted” (0.53), and “Attention to Yourself and Physical Sensations” (0.43). The items that load onto the third transformed component are “Attention Others” (0.87) and “Attention to Yourself and Physical Sensations” (0.47).
Note: TC stands for transformed components because they were rotated with the oblimin method.
Item Cluster Analysis: iclust
The item cluster analysis results are not included in the manuscript or in the supplementary material.
Note: “iclust is meant to do item cluster analysis using a hierarchical clustering algorithm specifically asking questions about the reliability of the clusters (Revelle, 1979). Clusters are formed until either coefficient α Cronbach (1951) or β Revelle (1979) fail to increase.”
“1. Find the proximity (e.g. correlation) matrix, 2. Identify the most similar pair of items 3. Combine this most similar pair of items to form a new variable (cluster), 4. Find the similarity of this cluster to all other items and clusters, 5. Repeat steps 2 and 3 until some criterion is reached (e.g., typicallly, if only one cluster remains or in iclust if there is a failure to increase reliability coefficients α or β). 6. Purify the solution by reassigning items to the most similar cluster center”
ic<-iclust(df_absorb)
ic## ICLUST (Item Cluster Analysis)
## Call: iclust(r.mat = df_absorb)
##
## Purified Alpha:
## C7 C8
## 0.73 0.62
##
## G6* reliability:
## C7 C8
## 0.33 1.00
##
## Original Beta:
## C7 C8
## 0.56 0.34
##
## Cluster size:
## C7 C8
## 5 5
##
## Item by Cluster Structure matrix:
## O P C7 C8
## own_world C8 C8 0.04 0.48
## absorbed_music C7 C7 -0.82 -0.19
## daydream C8 C8 0.09 0.71
## sense_time C7 C7 -0.53 0.01
## distracted C7 C8 0.48 0.65
## attentive C7 C7 -0.71 -0.52
## attention_others C8 C8 0.04 0.22
## attention_sensations C8 C8 -0.01 0.49
## positively_transformed C7 C7 -0.58 0.10
## negatively_transformed C7 C7 0.33 0.15
##
## With eigenvalues of:
## C7 C8
## 2.0 1.7
##
## Purified scale intercorrelations
## reliabilities on diagonal
## correlations corrected for attenuation above diagonal:
## C7 C8
## C7 0.73 0.26
## C8 0.17 0.62
##
## Cluster fit = 0.61 Pattern fit = 0.98 RMSR = 0.06summary(ic)## ICLUST (Item Cluster Analysis)Call: iclust(r.mat = df_absorb)
## ICLUST
##
## Purified Alpha:
## C7 C8
## 0.73 0.62
##
## Guttman Lambda6*
## C7 C8
## 0.74 0.65
##
## Original Beta:
## C7 C8
## 0.56 0.34
##
## Cluster size:
## C7 C8
## 5 5
##
## Purified scale intercorrelations
## reliabilities on diagonal
## correlations corrected for attenuation above diagonal:
## C7 C8
## C7 0.73 0.26
## C8 0.17 0.62Comparing FA, PCA, Cluster solutions
“Cluster analysis, factor analysis, and principal components analysis all produce structure matrices (matrices of correlations between the dimensions and the variables) that can in turn be compared in terms of the congruence coefficient which is just the cosine of the angle between the dimensions”
factor.congruence(list(absorption_factor_analysis_3,absorption_factor_analysis_4,absorption_PCA_3, ic))## MR1 MR2 MR3 MR1 MR2 MR3 MR4 TC1 TC2 TC3 C7 C8
## MR1 1.00 -0.03 -0.02 0.91 0.00 0.51 -0.13 0.99 -0.09 -0.04 -1.00 -0.42
## MR2 -0.03 1.00 0.16 -0.07 1.00 0.02 0.13 0.00 0.98 -0.04 0.10 0.79
## MR3 -0.02 0.16 1.00 -0.22 0.14 0.51 0.80 0.05 0.31 0.94 0.02 0.59
## MR1 0.91 -0.07 -0.22 1.00 -0.04 0.11 -0.07 0.87 -0.17 -0.17 -0.90 -0.50
## MR2 0.00 1.00 0.14 -0.04 1.00 0.01 0.12 0.03 0.98 -0.06 0.07 0.77
## MR3 0.51 0.02 0.51 0.11 0.01 1.00 -0.04 0.56 0.08 0.37 -0.52 0.05
## MR4 -0.13 0.13 0.80 -0.07 0.12 -0.04 1.00 -0.10 0.24 0.87 0.15 0.53
## TC1 0.99 0.00 0.05 0.87 0.03 0.56 -0.10 1.00 -0.05 0.02 -0.99 -0.36
## TC2 -0.09 0.98 0.31 -0.17 0.98 0.08 0.24 -0.05 1.00 0.10 0.16 0.87
## TC3 -0.04 -0.04 0.94 -0.17 -0.06 0.37 0.87 0.02 0.10 1.00 0.03 0.44
## C7 -1.00 0.10 0.02 -0.90 0.07 -0.52 0.15 -0.99 0.16 0.03 1.00 0.46
## C8 -0.42 0.79 0.59 -0.50 0.77 0.05 0.53 -0.36 0.87 0.44 0.46 1.00bassAckward
“Factor congruences may be found between any two sets of factor loadings. If given the same data set/correlation matrix, factor correlations may be found using faCor which finds the correlations between the factors. This procedure is also used in the bassAckward function which compares multiple solutions with a different number of factors.”
“bassAckward compares solutions at multiple levels by successive factoring and the finding the factor correlations across levels.”
bA<-bassAckward(df_absorb, nfactors = 3)
summary(bA)##
## Call: bassAckward(r = df_absorb, nfactors = 3)
##
## Factor correlations
## F1
## F1 0.86
##
## Factor correlations
## F1
## F1 0.84
## F2 -0.52
##
## Factor correlations
## F1 F2
## F1 1.00 -0.29
## F2 -0.09 0.89
## F3 -0.06 0.68Repeated Measures Correlations
Section 3.3 What is the relation between absorption in the music, the other scale factors, and other affective variables?
Correlations between variables by piece needs to be conducted with a repeated measures approach because we measured the scales after Beethoven, Schnittke, and the Folk (3 times)
There is a toolbox that was developed just for this kind of analysis called rmcorr (Bakdash & Marusich, 2017). https://www.frontiersin.org/articles/10.3389/fpsyg.2017.00456/full
“Rmcorr accounts for non-independence among observations using analysis of covariance (ANCOVA) to statistically adjust for inter-individual variability. By removing measured variance between-participants, rmcorr provides the best linear fit for each participant using parallel regression lines (the same slope) with varying intercepts. Like a Pearson correlation coefficient (r), the rmcorr coefficient (rrm) is bounded by −1 to 1 and represents the strength of the linear association between two variables. Also akin to the Pearson correlation, the null hypothesis for rmcorr is ρrm = 0, and the research/alternative hypothesis is ρrm 6= 0. Unlike the Pearson correlation, which assesses the inter-individual association because it assumes each paired data point is Independent and Identically Distributed (IID), rmcorr evaluates the overall or common intra-individual association between two measures. Because rmcorr takes into account non-independence, it tends to yield much greater power than data that are averaged in order to meet the IID assumption for simple regression/correlation. Hence, rmcorr can detect associations between variables that might otherwise be obscured or spurious due to aggregation or treating non-independent values as IID.
Conceptually, rmcorr is close to a null multilevel model (i.e., varying intercept and a common slope for each individual), but the techniques differ on how they treat/pool variance. Rmcorr assesses the common intra-individual variance in data, whereas multilevel modeling can simultaneously analyze different sources of variance using fixed and random effects. The tradeoff with more complex multilevel models is that they require more data and are more challenging to specify and interpret than simpler analysis of variance (ANOVA)/regression models, such as rmcorr. However, the flexibility of multilevel modeling has benefits: Overall and individual differences can be analyzed simultaneously, models of varying complexity can be systematically compared, and they can provide greater insights into individual differences.”
“Rmcorr can be viewed as a “light” version of multilevel modeling because it is comparable to a simple, null multilevel model with random/varying effects of intercept for each individual and a fixed effect (i.e., common/overall) slope (see Appendix C for direct comparisons). However, rmcorr only analyzes intra- individual variance. Multilevel modeling can simultaneously analyze both intra- and inter-individual variance using partial pooling, which permits varying slopes and other parameters that cannot be estimated with simpler techniques.
Correlation Matrix
This is figure 1 in the manuscript, located in section 3.3
Include all repeated measures for Beethoven, Schnittke, Folk and Motion measures! - connectedness (musicians and audience) - awe - km - absorption factors (x4)
Did not include motion (QoM) and stilling because we might expect the relation between absorption and motion to be different for different pieces due to the sociocultural genre constraints.
# execute the code so that you know you have the correct data
cormat_df<-df.full%>%select(Pt_ID,contains("Absorption"), contains("Mind-wandering"), contains("Positive_Affect"),contains("Attention_Away"), contains("KM"), contains("AWE_wonder"), contains("connected_musicians"), contains("connected_audience"), contains("familiar"),contains("enjoy"))
cormat_df.long<-cormat_df%>%pivot_longer(!Pt_ID,
names_to = c("var", "piece"),
names_pattern ="(.*)_(.*)",
values_to = "response")
cormat_df.long<-cormat_df.long%>%filter(var != "connected_audience_streaming", var != "connected_audience_attending")
cormat_df.wide<-pivot_wider(cormat_df.long, names_from = var, values_from = response)
# rename the vars so they appear pretty in the chart
colnames(cormat_df.wide)<-c("Pt_ID", "piece", "Absorption","Mind-wandering", "Positive Transformation", "Attention Away","Kama Muta","Awe", "Connected Musicians", "Connected Audience","Familiar","Enjoyment")
variables<-c("Absorption","Mind-wandering", "Positive Transformation", "Attention Away","Kama Muta","Awe", "Connected Musicians", "Connected Audience","Familiar","Enjoyment")
rmc_mat<-rmcorr_mat(Pt_ID, variables, cormat_df.wide, CI.level = 0.95)In the next cell, I need to adjust the rmc_mat so that I only have the matrix that I want visualized.
# filter such that measure 1 contains only the absorption factors
absorb_factor_names<-c("Absorption", "Mind-wandering", "Positive Transformation", "Attention Away")
adjusted_summary<-rmc_mat$summary%>%filter(measure1 %in% absorb_factor_names)Then create corrected p-values (correction = FDR adjustment)
adjusted_matrix<-rmc_mat$matrix[1:4, 2:10]
r.mat<-adjusted_matrix# use the rm_adjusted.corr function outside of the function to be able to check that everything is working. -- the following code is copy pasted and adjusted based on that function.
# assign function variables
cor_df<-cormat_df.wide%>%dplyr::select(-Pt_ID, -piece)
p.adjust = TRUE
p.adjust.method = "fdr"
# p.adjust methods: # c("holm", "hochberg", "hommel", "bonferroni", "BH", "BY",
# "fdr", "none") # Lol: note that BH and FDR are the same method (it seems) https://support.bioconductor.org/p/110897/#:~:text=%22BH%22%20and%20%22fdr%22%20are%20the%20same%20method.,an%20alias%20for%20%22BH%22.
threshold = 0.05
cor.method = "repeated"
if (p.adjust==TRUE){
p.vals <- p.adjust(adjusted_summary$p.vals,
method = p.adjust.method,
n = length(adjusted_summary$p.vals))
} else {
p.vals = adjusted_summary$p.vals
}
# initiate empty matrix for the p-values only
MAT = matrix(NA, nrow = length(unique(adjusted_summary$measure1)), ncol = length(unique(adjusted_summary$measure2)))
rownames(MAT) = unique(adjusted_summary$measure1)
colnames(MAT) = unique(adjusted_summary$measure2)
# starting to convert p.list to p.values matrix
for(ind in 1:(length(p.vals))){
var1 = adjusted_summary$measure1[ind] # var1
var2 = adjusted_summary$measure2[ind] # var1
p.value = p.vals[ind] # p value
MAT[var1, var2] = p.value
}
# At this point, MAT has the p.values in a matrix
# subset only the coefficients with p values < 0.05 (or than the specified threshold)
subset = ifelse(MAT < threshold, r.mat, NA)
output = list(adj.p.values = MAT, threshold.r = subset)Title = "Correlation Matrix"
colours_blue_white_red<-c("#2d769a", "white","#b34036") # update colors as you wish
Subtitle = "Repeated Measures Correlations - FDR Adjusted"
rm_correlation.matrix(output, colours_blue_white_red, Title, Subtitle)
graphname<-paste0("../plots/RM_Correlations_continuous_fdr.png")
ggsave(graphname, width = 12, height = 10, units = 'cm', dpi = 500)Inspect the rmcorr values and p-values to write the results section
output## $adj.p.values
## Mind-wandering Positive Transformation Attention Away
## Absorption 0.001205612 1.484374e-17 0.0004207863
## Mind-wandering NA 4.715824e-02 0.0692430624
## Positive Transformation NA NA 0.0109486579
## Attention Away NA NA NA
## Kama Muta Awe Connected Musicians
## Absorption 1.038331e-19 0.004892691 1.236017e-13
## Mind-wandering 4.631567e-02 0.021718491 4.206295e-01
## Positive Transformation 1.020156e-26 0.457895677 1.506334e-12
## Attention Away 7.593910e-01 0.980953669 9.531241e-01
## Connected Audience Familiar Enjoyment
## Absorption 3.265374e-04 0.01121658 2.898889e-26
## Mind-wandering 4.636459e-01 0.75939103 1.791117e-01
## Positive Transformation 5.051716e-08 0.01758326 9.450068e-21
## Attention Away 3.411634e-04 0.61035910 1.379440e-01
##
## $threshold.r
## Mind-wandering Positive Transformation Attention Away
## Absorption -0.2298278 0.5366787 -0.2485759
## Mind-wandering NA -0.1441927 NA
## Positive Transformation NA NA 0.1852575
## Attention Away NA NA NA
## Kama Muta Awe Connected Musicians
## Absorption 0.5655000 0.2056553 0.4861708
## Mind-wandering -0.1460578 0.1681373 NA
## Positive Transformation 0.6459282 NA 0.4665273
## Attention Away NA NA NA
## Connected Audience Familiar Enjoyment
## Absorption 0.2613483 0.1865900 0.6477406
## Mind-wandering NA NA NA
## Positive Transformation 0.3736810 0.1751971 0.5879221
## Attention Away 0.2589966 NA NAoutput$adj.p.values## Mind-wandering Positive Transformation Attention Away
## Absorption 0.001205612 1.484374e-17 0.0004207863
## Mind-wandering NA 4.715824e-02 0.0692430624
## Positive Transformation NA NA 0.0109486579
## Attention Away NA NA NA
## Kama Muta Awe Connected Musicians
## Absorption 1.038331e-19 0.004892691 1.236017e-13
## Mind-wandering 4.631567e-02 0.021718491 4.206295e-01
## Positive Transformation 1.020156e-26 0.457895677 1.506334e-12
## Attention Away 7.593910e-01 0.980953669 9.531241e-01
## Connected Audience Familiar Enjoyment
## Absorption 3.265374e-04 0.01121658 2.898889e-26
## Mind-wandering 4.636459e-01 0.75939103 1.791117e-01
## Positive Transformation 5.051716e-08 0.01758326 9.450068e-21
## Attention Away 3.411634e-04 0.61035910 1.379440e-01output$threshold.r## Mind-wandering Positive Transformation Attention Away
## Absorption -0.2298278 0.5366787 -0.2485759
## Mind-wandering NA -0.1441927 NA
## Positive Transformation NA NA 0.1852575
## Attention Away NA NA NA
## Kama Muta Awe Connected Musicians
## Absorption 0.5655000 0.2056553 0.4861708
## Mind-wandering -0.1460578 0.1681373 NA
## Positive Transformation 0.6459282 NA 0.4665273
## Attention Away NA NA NA
## Connected Audience Familiar Enjoyment
## Absorption 0.2613483 0.1865900 0.6477406
## Mind-wandering NA NA NA
## Positive Transformation 0.3736810 0.1751971 0.5879221
## Attention Away 0.2589966 NA NASplit live and livestreaming audiences for correlation chart visualizations
To better understand how the different audiences/social contexts influence the relation between variables, split the data into groups. This is included in the supplementary material figure 2.
Live
cormat_df<-df.full%>%select(Pt_ID,group, contains("Absorption"), contains("Mind-wandering"), contains("Positive_Affect"),contains("Attention_Away"), contains("KM"), contains("AWE_wonder"), contains("connected_musicians"), contains("connected_audience"), contains("familiar"),contains("enjoy")) #, contains("mQoM"), contains("Stilling"))
cormat_df_live<-cormat_df%>%filter(group == "Live")
cormat_df_live.long<-cormat_df_live%>%pivot_longer(!c(Pt_ID,group),
names_to = c("var", "piece"),
names_pattern ="(.*)_(.*)",
values_to = "response")
cormat_df_live.long<-cormat_df_live.long%>%filter(var != "connected_audience_streaming", var != "connected_audience_attending")
cormat_df_live.long<-cormat_df_live.long%>%select(-group)
cormat_df_live.wide<-pivot_wider(cormat_df_live.long, names_from = var, values_from = response)colnames(cormat_df_live.wide)## [1] "Pt_ID" "piece" "Absorption"
## [4] "Mind-wandering" "Positive_Affect" "Attention_Away"
## [7] "KM" "AWE_wonder" "connected_musicians"
## [10] "connected_audience" "familiar" "enjoy"# rename the vars so they appear pretty in the chart
colnames(cormat_df_live.wide)<-c("Pt_ID", "piece", "Absorption","Mind-wandering", "Positive Transformation", "Attention Away","Kama Muta","Awe", "Connected Musicians", "Connected Audience","Familiar","Enjoyment")#,"QoM", "Stilling")
cor_df<-cormat_df_live.wide%>%dplyr::select(-Pt_ID, -piece)
variables<-c("Absorption","Mind-wandering", "Positive Transformation", "Attention Away","Kama Muta","Awe", "Connected Musicians", "Connected Audience","Familiar","Enjoyment")#,"QoM", "Stilling")
rmc_mat<-rmcorr_mat(Pt_ID, variables, cormat_df_live.wide, CI.level = 0.95)
# create corrected p-values (correction = FDR adjustment)
correlation_fdr = rm_adjusted.corr(rmc_mat, cor_df, p.adjust = TRUE, p.adjust.method = "fdr", threshold = 0.05, cor.method = "repeated")
Title = "Correlation Matrix: Live"
colours_blue_white_red<-c("#2d769a", "white","#b34036") # update colors as you wish
Subtitle = "Repeated Measures Correlations - FDR Adjusted"
rm_correlation.matrix(correlation_fdr, colours_blue_white_red, Title, Subtitle)
graphname<-paste0("../plots/RM_Correlations_continuous_fdr_live.png")
ggsave(graphname, width = 12, height = 10, units = 'cm', dpi = 500)Livestreaming
cormat_df<-df.full%>%select(Pt_ID,group, contains("Absorption"), contains("Mind-wandering"), contains("Positive_Affect"),contains("Attention_Away"), contains("KM"), contains("AWE_wonder"), contains("connected_musicians"), contains("connected_audience"), contains("familiar"),contains("enjoy"))#, contains("mQoM"))
cormat_df_livestreaming<-cormat_df%>%filter(group == "Virtual")
cormat_df_livestreaming.long<-cormat_df_livestreaming%>%pivot_longer(!c(Pt_ID,group),
names_to = c("var", "piece"),
names_pattern ="(.*)_(.*)",
values_to = "response")
cormat_df_livestreaming.long<-cormat_df_livestreaming.long%>%filter(var != "connected_audience_streaming", var != "connected_audience_attending")
cormat_df_livestreaming.long<-cormat_df_livestreaming.long%>%select(-group)
cormat_df_livestream.wide<-pivot_wider(cormat_df_livestreaming.long, names_from = var, values_from = response)colnames(cormat_df_livestream.wide)## [1] "Pt_ID" "piece" "Absorption"
## [4] "Mind-wandering" "Positive_Affect" "Attention_Away"
## [7] "KM" "AWE_wonder" "connected_musicians"
## [10] "connected_audience" "familiar" "enjoy"# rename the vars so they appear pretty in the chart
colnames(cormat_df_livestream.wide)<-c("Pt_ID", "piece", "Absorption","Mind-wandering", "Positive Transformation", "Attention Away","Kama Muta","Awe", "Connected Musicians", "Connected Audience","Familiar","Enjoyment")#,"QoM")
cor_df<-cormat_df_livestream.wide%>%dplyr::select(-Pt_ID, -piece)
variables<-c("Absorption","Mind-wandering", "Positive Transformation", "Attention Away","Kama Muta","Awe", "Connected Musicians", "Connected Audience","Familiar","Enjoyment")#,"QoM")
rmc_mat<-rmcorr_mat(Pt_ID, variables, cormat_df_livestream.wide, CI.level = 0.95)
# create corrected p-values (correction = FDR adjustment)
correlation_fdr = rm_adjusted.corr(rmc_mat, cor_df, p.adjust = TRUE, p.adjust.method = "fdr", threshold = 0.05, cor.method = "repeated")
Title = "Correlation Matrix: Livestreaming"
colours_blue_white_red<-c("#2d769a", "white","#b34036") # update colors as you wish
Subtitle = "Repeated Measures Correlations - FDR Adjusted"
rm_correlation.matrix(correlation_fdr, colours_blue_white_red, Title, Subtitle)
graphname<-paste0("../plots/RM_Correlations_continuous_fdr_livestreaming.png")
ggsave(graphname, width = 12, height = 10, units = 'cm', dpi = 500)3.3.1 Absorption Scale factors: Mind-wandering, Attention, and Absorption
To be able to thoroughly inspect the relations between variables with the plots, conduct rmcorr separately. Note that the p-values in the following sections are uncorrected. Refer to the correlation matrix and the manuscript for FDR corrected p-values.
- What is the relation between on the one hand mind wandering and attention, and on the other hand absorption?
Absorption x Mind-wandering
Absorption and mind-wandering are negatively correlated (r = -.24, p < .001). The more absorbed people were, the less they mind wandered. The more mind wandering, the less absorption.
abs_mw.rmc<-rmcorr(participant = "Pt_ID", measure1 = "Mind-wandering", measure2 = "Absorption", dataset = absorbed_factors)## Warning in rmcorr(participant = "Pt_ID", measure1 = "Mind-wandering", measure2 =
## "Absorption", : 'Pt_ID' coerced into a factorabs_mw.rmc##
## Repeated measures correlation
##
## r
## -0.2298278
##
## degrees of freedom
## 225
##
## p-value
## 0.0004822448
##
## 95% confidence interval
## -0.3500949 -0.1021065plot(abs_mw.rmc, absorbed_factors, lty = 2)## Warning in plot.rmc(abs_mw.rmc, absorbed_factors, lty = 2): dataset parameter is
## deprecated
Absorption x Attention Away
Absorption and attention away are negatively correlated (r = -.26, p < .001). The more absorbed people were, the less they directed their attention away.
abs_aa.rmc<-rmcorr(participant = "Pt_ID", measure1 = "Attention_Away", measure2 = "Absorption", dataset = absorbed_factors)## Warning in rmcorr(participant = "Pt_ID", measure1 = "Attention_Away", measure2 =
## "Absorption", : 'Pt_ID' coerced into a factorabs_aa.rmc##
## Repeated measures correlation
##
## r
## -0.2485759
##
## degrees of freedom
## 225
##
## p-value
## 0.0001542883
##
## 95% confidence interval
## -0.3674211 -0.1217433plot(abs_aa.rmc, absorbed_factors, lty = 2)## Warning in plot.rmc(abs_aa.rmc, absorbed_factors, lty = 2): dataset parameter is
## deprecated
Absorption x Positive Affect
Absorption and positive affect are positively correlated (r = .51, p < .001). Absorption is an experience that is related to positive affect.
abs_pa.rmc<-rmcorr(participant = "Pt_ID", measure1 = "Positive_Affect", measure2 = "Absorption", dataset = absorbed_factors)## Warning in rmcorr(participant = "Pt_ID", measure1 = "Positive_Affect", measure2
## = "Absorption", : 'Pt_ID' coerced into a factorabs_pa.rmc##
## Repeated measures correlation
##
## r
## 0.5366787
##
## degrees of freedom
## 225
##
## p-value
## 2.473957e-18
##
## 95% confidence interval
## 0.4365292 0.6236909plot(abs_pa.rmc, absorbed_factors, lty = 2)## Warning in plot.rmc(abs_pa.rmc, absorbed_factors, lty = 2): dataset parameter is
## deprecated
Mind-wandering x Attention Away
Weakly correlated. Suggests that attention directed away from the music (attention directed to others or yourself/sensations) is weakly correlated to mind wandering (absorbed in your own world/day dreaming).
aa_mw.rmc<-rmcorr(participant = "Pt_ID", measure1 = "Attention_Away", measure2 = "Mind-wandering", dataset = absorbed_factors)## Warning in rmcorr(participant = "Pt_ID", measure1 = "Attention_Away", measure2 =
## "Mind-wandering", : 'Pt_ID' coerced into a factoraa_mw.rmc##
## Repeated measures correlation
##
## r
## 0.1324878
##
## degrees of freedom
## 225
##
## p-value
## 0.04616204
##
## 95% confidence interval
## 0.001727101 0.258794plot(aa_mw.rmc, absorbed_factors, lty = 2)## Warning in plot.rmc(aa_mw.rmc, absorbed_factors, lty = 2): dataset parameter is
## deprecated
3.3.2 Kama muta and awe
Absorption and Kama Muta
- What is the relation between absorption and Kama Muta?
Absorption and kama muta are positively correlated (r = .56, p < .001)
kama_muta_avg<-df_KM.wide%>%select(KM,Pt_ID, piece)
df_abs_km<-full_join(kama_muta_avg, absorbed_factors, by = c("Pt_ID", "piece"))
km_abs.rmc<-rmcorr(participant = "Pt_ID", measure1 = "KM", measure2 = "Absorption", dataset = df_abs_km)## Warning in rmcorr(participant = "Pt_ID", measure1 = "KM", measure2 =
## "Absorption", : 'Pt_ID' coerced into a factorkm_abs.rmc##
## Repeated measures correlation
##
## r
## 0.5655
##
## degrees of freedom
## 225
##
## p-value
## 1.384441e-20
##
## 95% confidence interval
## 0.4694294 0.6483382plot(km_abs.rmc, df_abs_km, lty = 2)## Warning in plot.rmc(km_abs.rmc, df_abs_km, lty = 2): dataset parameter is
## deprecated
Absorption and Awe
Absorption and awe are not correlated. Awe and wonder is correlated with absorption. Therefore the addition of that one item (I was filled with admiration and wonder) facilitates the correlation of awe with absorption. Awe and wonder is the variable reported in the manuscript in accordance with the collectively classical manuscript.
## AWE (no admiration and wonder item)
awe_avg<-df_awe.wide%>%select(AWE,Pt_ID, piece)
df_abs_awe<-full_join(awe_avg, absorbed_factors, by = c("Pt_ID", "piece"))
awe_abs.rmc<-rmcorr(participant = "Pt_ID", measure1 = "AWE", measure2 = "Absorption", dataset = df_abs_awe)## Warning in rmcorr(participant = "Pt_ID", measure1 = "AWE", measure2 =
## "Absorption", : 'Pt_ID' coerced into a factorawe_abs.rmc##
## Repeated measures correlation
##
## r
## 0.1079523
##
## degrees of freedom
## 219
##
## p-value
## 0.1095084
##
## 95% confidence interval
## -0.02497881 0.2371323plot(awe_abs.rmc, df_abs_awe, lty = 2)## Warning in plot.rmc(awe_abs.rmc, df_abs_awe, lty = 2): dataset parameter is
## deprecated
## AWE and wonder
awe_avg<-df_awe.wide%>%select(AWE_wonder,Pt_ID, piece)
df_abs_awe<-full_join(awe_avg, absorbed_factors, by = c("Pt_ID", "piece"))
awe_abs.rmc<-rmcorr(participant = "Pt_ID", measure1 = "AWE_wonder", measure2 = "Absorption", dataset = df_abs_awe)## Warning in rmcorr(participant = "Pt_ID", measure1 = "AWE_wonder", measure2 =
## "Absorption", : 'Pt_ID' coerced into a factorawe_abs.rmc##
## Repeated measures correlation
##
## r
## 0.2056553
##
## degrees of freedom
## 219
##
## p-value
## 0.002120166
##
## 95% confidence interval
## 0.07513001 0.3292521plot(awe_abs.rmc, df_abs_awe, lty = 2)## Warning in plot.rmc(awe_abs.rmc, df_abs_awe, lty = 2): dataset parameter is
## deprecated
Kama muta and awe
Kama muta and awe are correlated with each other.
df_km_awe<-full_join(awe_avg, kama_muta_avg, by = c("Pt_ID", "piece"))
awe_km.rmc<-rmcorr(participant = "Pt_ID", measure1 = "AWE_wonder", measure2 = "KM", dataset = df_km_awe)## Warning in rmcorr(participant = "Pt_ID", measure1 = "AWE_wonder", measure2 =
## "KM", : 'Pt_ID' coerced into a factorawe_km.rmc##
## Repeated measures correlation
##
## r
## 0.1949959
##
## degrees of freedom
## 234
##
## p-value
## 0.00262444
##
## 95% confidence interval
## 0.0684619 0.3153557plot(awe_km.rmc, df_km_awe, overall = TRUE, lty = 2)## Warning in plot.rmc(awe_km.rmc, df_km_awe, overall = TRUE, lty = 2): dataset
## parameter is deprecated
AIMS and Awe
In related research: Trait-based measures of absorption predict awe and instructing people to be absorbed in their experience also increases the experience of awe (van Elk et al., 2016). Therefore, check whether AIMS predicted AWE. First try separate linear models.
# get data
df_awe_aims<-df.full%>%select(Pt_ID, AIMS, group, contains("AWE"))
# make long
df_awe_aims.long<-df_awe_aims%>%pivot_longer(!c(Pt_ID, AIMS, group), #make long
names_to = c("var", "piece"),
names_pattern ="(.*)_(.*)",
values_to = "response")
df_awe_aims.wide<-df_awe_aims.long%>%pivot_wider(names_from = var, values_from = response)
df_awe_aims.wide$piece<-factor(df_awe_aims.wide$piece, levels = c("Beethoven", "Schnittke", "Bach", "Folk"))
#factor for the correct facet order
df_awe_aims.wide_nona<-df_awe_aims.wide%>%drop_na() #408 to 351baseline_awe<-lmer(AWE_wonder ~ 1 + (1|Pt_ID), data = df_awe_aims.wide_nona, REML = FALSE)
awe_aims<-lmer(AWE_wonder ~ AIMS + (1|Pt_ID), data = df_awe_aims.wide_nona, REML = FALSE)
anova(baseline_awe, awe_aims)## Data: df_awe_aims.wide_nona
## Models:
## baseline_awe: AWE_wonder ~ 1 + (1 | Pt_ID)
## awe_aims: AWE_wonder ~ AIMS + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline_awe 3 969.13 980.71 -481.57 963.13
## awe_aims 4 959.91 975.35 -475.96 951.91 11.22 1 0.000809 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1summary(awe_aims)## Linear mixed model fit by maximum likelihood ['lmerMod']
## Formula: AWE_wonder ~ AIMS + (1 | Pt_ID)
## Data: df_awe_aims.wide_nona
##
## AIC BIC logLik deviance df.resid
## 959.9 975.4 -476.0 951.9 347
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -2.3418 -0.5470 0.0347 0.5630 3.3967
##
## Random effects:
## Groups Name Variance Std.Dev.
## Pt_ID (Intercept) 0.7752 0.8804
## Residual 0.4859 0.6970
## Number of obs: 351, groups: Pt_ID, 122
##
## Fixed effects:
## Estimate Std. Error t value
## (Intercept) 1.626714 0.414308 3.926
## AIMS 0.012152 0.003545 3.428
##
## Correlation of Fixed Effects:
## (Intr)
## AIMS -0.977Check assumptions
plot(awe_aims)
#### QQPlot
ggqqplot(df_awe_aims.wide_nona, "AWE_wonder", ggtheme = theme_bw()) +
facet_grid(piece ~ group)
Visualize the relation: Included in the supplementary material: figure 3
title = "Awe & AIMS"
# r
p<-df_awe_aims.wide%>%
ggplot(aes(x = AIMS, y = AWE_wonder))+
geom_point(alpha = .5)+
labs(title =title,x = "AIMS", y = "Awe")+
geom_smooth(method = lm)+
facet_grid(rows = vars(piece), cols = vars(group))+
theme_minimal()+
stat_cor(aes(label = ..r.label..), color = "blue", geom = "label")
p## `geom_smooth()` using formula 'y ~ x'## Warning: Removed 57 rows containing non-finite values (stat_smooth).## Warning: Removed 57 rows containing non-finite values (stat_cor).## Warning: Removed 57 rows containing missing values (geom_point).
p<-df_awe_aims.wide%>%
ggplot(aes(x = AIMS, y = AWE_wonder))+
geom_point(alpha = .5)+
labs(title =title,x = "AIMS", y = "Awe")+
geom_smooth(method = lm)+
#facet_grid(rows = vars(piece), cols = vars(group))+
theme_minimal()+
stat_cor(aes(label = paste(..r.label.., ..p.label.., sep = "~`,`~")), color = "blue", geom = "label")
graphname<-paste0("../plots/", title,".png")
ggsave(graphname, width = 15, height = 10, units = 'cm', dpi = 500)## `geom_smooth()` using formula 'y ~ x'## Warning: Removed 57 rows containing non-finite values (stat_smooth).## Warning: Removed 57 rows containing non-finite values (stat_cor).## Warning: Removed 57 rows containing missing values (geom_point).3.3.3 Familiarity, Enjoyment, Connectedness
df_famil_enjoy<-df.full%>%select("Pt_ID", contains(c("familiar", "enjoy")))%>%select(!familiar_Bach)
df_famil_enjoy.long<-df_famil_enjoy%>%pivot_longer(!Pt_ID,
names_to = c("question", "piece"),
names_pattern ="(.*)_(.*)",
values_to = "response")
df_famil_enjoy.wide<-df_famil_enjoy.long%>%pivot_wider(names_from = question, values_from = response)
describe(df_famil_enjoy.wide)## vars n mean sd median trimmed mad min max range skew kurtosis
## Pt_ID* 1 408 68.50 39.31 68.5 68.50 50.41 1 136 135 0.00 -1.21
## piece* 2 408 2.00 0.82 2.0 2.00 1.48 1 3 2 0.00 -1.51
## familiar 3 363 2.46 2.21 2.0 2.33 2.97 0 6 6 0.23 -1.46
## enjoy 4 364 5.02 1.26 5.0 5.25 1.48 0 6 6 -1.47 2.17
## se
## Pt_ID* 1.95
## piece* 0.04
## familiar 0.12
## enjoy 0.07df_fam_enj_abs<-full_join(df_famil_enjoy.wide, absorbed_factors, by = c("Pt_ID", "piece"))Familiarity
Being familiar with the music was positively correlated with absorption (r = .19, p = .006).
fam_abs.rmc<-rmcorr(participant = "Pt_ID", measure1 = "familiar", measure2 = "Absorption", dataset = df_fam_enj_abs)## Warning in rmcorr(participant = "Pt_ID", measure1 = "familiar", measure2 =
## "Absorption", : 'Pt_ID' coerced into a factorfam_abs.rmc##
## Repeated measures correlation
##
## r
## 0.18659
##
## degrees of freedom
## 217
##
## p-value
## 0.005608291
##
## 95% confidence interval
## 0.05476661 0.3120205plot(fam_abs.rmc, absorbed_factors, lty = 2)## Warning in plot.rmc(fam_abs.rmc, absorbed_factors, lty = 2): dataset parameter
## is deprecated
Enjoyment
Enjoying the music was positively correlated with absorption (r = .65, p < .001). Recall that this result is simply correlational and not causational so there is no way to know whether enjoyment leads to better absorption or if absorption leads to enjoyment.
enj_abs.rmc<-rmcorr(participant = "Pt_ID", measure1 = "enjoy", measure2 = "Absorption", dataset = df_fam_enj_abs)## Warning in rmcorr(participant = "Pt_ID", measure1 = "enjoy", measure2 =
## "Absorption", : 'Pt_ID' coerced into a factorenj_abs.rmc##
## Repeated measures correlation
##
## r
## 0.6477406
##
## degrees of freedom
## 217
##
## p-value
## 1.932592e-27
##
## 95% confidence interval
## 0.5631374 0.7189057plot(enj_abs.rmc, absorbed_factors, lty = 2)## Warning in plot.rmc(enj_abs.rmc, absorbed_factors, lty = 2): dataset parameter
## is deprecated
3.4 Personal Characteristics and Absorption
- What is the impact of previous musical training/acquaintance with the performed music/personal relation to the DSQ on absorption?
Personal Characteristcis (EC, AIMS, Musician, Relationship, Fan) x Absorption
(Musical training, Acquaintance with music, personal relations to the performers, empathy)
Use a multiple regression approach to assess which variables predict absorption.
Average absorption over the three pieces because personal characteristics are the same across pieces.
What is the relation between absorption and traits? * Empathic concern * AIMS * Musician Status * Personal Relation to the Performers * Fan status
personal_variables<-c("EC", "AIMS", "musician_status", "personal_relation", "fan")
df_personal<-df.full%>%select("Pt_ID",group,personal_variables)## Note: Using an external vector in selections is ambiguous.
## ℹ Use `all_of(personal_variables)` instead of `personal_variables` to silence this message.
## ℹ See <https://tidyselect.r-lib.org/reference/faq-external-vector.html>.
## This message is displayed once per session.describe(df_personal)## vars n mean sd median trimmed mad min max range
## Pt_ID* 1 136 68.50 39.40 68.5 68.50 50.41 1 136 135
## group* 2 136 1.33 0.47 1.0 1.29 0.00 1 2 1
## EC 3 126 3.91 0.64 4.0 3.94 0.64 1 5 4
## AIMS 4 122 114.25 24.96 117.0 115.31 26.69 50 164 114
## musician_status* 5 126 3.98 1.51 3.0 3.84 1.48 1 7 6
## personal_relation* 6 126 1.17 0.37 1.0 1.09 0.00 1 2 1
## fan 7 124 5.06 2.41 6.0 5.32 1.48 1 7 6
## skew kurtosis se
## Pt_ID* 0.00 -1.23 3.38
## group* 0.71 -1.51 0.04
## EC -0.83 2.23 0.06
## AIMS -0.39 -0.39 2.26
## musician_status* 0.82 -0.42 0.13
## personal_relation* 1.77 1.13 0.03
## fan -0.85 -0.97 0.22# average the absorption factors across all 3 pieces.
absorbed_mean<-absorbed_factors%>%group_by(Pt_ID)%>%summarise(absorb_mean = mean(Absorption),
mw_mean = mean(`Mind-wandering`),
pa_mean = mean (Positive_Affect),
aa_mean = mean(Attention_Away))
df_personal_abs<-full_join(df_personal, absorbed_mean, by = c("Pt_ID"))Regression
DV: absorption (continuous)
IV: personal characteristics Continuous: EC, AIMS Ordinal: musician_status, fan Categorical: personal_relation
Multiple regression notes from the textbook (Field) The more predictors you add, the higher R^2 will be (explantory power of the model). Therefore the Aikake Information Criterion (AIC) is a better measure of the fit of a model. It penalizes extra predictors. (A little like adjusted R^2). The higher the AIC, the worse the model fit is. AIC can be used to compare models with the same outcome measure.
Care should be taken when selecting which predictors to be entered in the model. When predictors are all completely uncorrelated, then the order of entry into the model doesn’t matter as much. However there are rarely uncorrelated predictors.
Choosing parameter and their order: - Hierarchical: predictors are selected based on past research and the experimenter decides how to add them to the model, in order of importance of the predictor based on past research. New predictors suspected to be the most important should be entered first. - Forced entry: all predictors are added without consideration for order. - Stepwise: R mathematically assesses whether the addition of a predictor contributed to better fit or not with the AIC. The backwards selection approach leads to less suppressor effects than the forward selection approach so it should be favoured. However generally statisticians frown upon stepwise regression approaches. - All subsets method: tests all combinations of the predictors. With 6 variables, it will be 64 combinations (2**6). This shouldn’t be too computationally intensive.
What method to choose? Use theoretical literature to include meaningful variables in their order of importance first, then repeat the regression, but exclude variables that were statistically redundant the first time.
Step 1: Think critically about the variables and what would be most likely to influence absorption.
The AIMS should be the variable that most influences a propensity to be absorbed (because that is exactly what it is supposed to measure). Then fan-status is likely to be important for fostering feelings of absorption, based on my own musical experiences. I would not know what would be most important between EC, musician status, and personal relation. Perhaps one approach would be to examine the correlations.
Step 2: Correlations
Interestingly, the correlation indicates that fan-status may actually be more related to participants’ experiences of absorption than AIMS.
cor_df_personal_chars<-df_personal_abs%>%select(-Pt_ID, -musician_status, -personal_relation, -group)
cor.plot(cor_df_personal_chars, numbers = TRUE)
Step 3: Make the model
Set the categorical contrasts
# Musician Status
summary(df_personal_abs$musician_status)## Tone-deaf Nonmusician Music-loving nonmusician
## 1 8 60
## Amateur musician Serious amateur musician Semiprofessional musician
## 18 17 6
## Professional musician NA's
## 16 10contrasts(df_personal_abs$musician_status)<-contr.treatment(7, base = 1)
#Baseline: tone-deaf. there is only one tone-deaf person though so maybe we should change the baseline to the group with the most number of people (3)
#df_personal_abs$musician_status # execute this to check contrasts.
# Personal Relation
summary(df_personal_abs$personal_relation)## No_Relation Relative_Friend NA's
## 105 21 10contrasts(df_personal_abs$personal_relation)<-contr.treatment(2, base = 1)
#Baseline: no personal relation
#df_personal_abs$personal_relation # execute this to check contrasts. Model
m1<-lm(absorb_mean ~ AIMS + fan, data = df_personal_abs)
summary(m1) # Adjusted R-Squared = .23##
## Call:
## lm(formula = absorb_mean ~ AIMS + fan, data = df_personal_abs)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.47073 -0.51210 -0.01906 0.43432 1.89859
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -1.437402 0.324763 -4.426 2.56e-05 ***
## AIMS 0.007433 0.002745 2.707 0.00804 **
## fan 0.126074 0.029271 4.307 4.03e-05 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.6773 on 95 degrees of freedom
## (38 observations deleted due to missingness)
## Multiple R-squared: 0.2451, Adjusted R-squared: 0.2292
## F-statistic: 15.42 on 2 and 95 DF, p-value: 1.588e-06m2<-update(m1, .~. + personal_relation + musician_status + EC)
summary(m2)##
## Call:
## lm(formula = absorb_mean ~ AIMS + fan + personal_relation + musician_status +
## EC, data = df_personal_abs)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.63519 -0.44800 -0.01367 0.51882 1.78698
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -1.575976 0.752245 -2.095 0.0391 *
## AIMS 0.005632 0.003286 1.714 0.0901 .
## fan 0.135183 0.032107 4.210 6.19e-05 ***
## personal_relation2 0.148936 0.214176 0.695 0.4887
## musician_status2 -0.762774 0.759052 -1.005 0.3177
## musician_status3 -0.510620 0.714067 -0.715 0.4765
## musician_status4 -0.426506 0.722613 -0.590 0.5566
## musician_status5 -0.811565 0.736039 -1.103 0.2732
## musician_status6 -0.603876 0.760274 -0.794 0.4292
## musician_status7 -0.880239 0.743801 -1.183 0.2399
## EC 0.220987 0.120043 1.841 0.0690 .
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.6764 on 87 degrees of freedom
## (38 observations deleted due to missingness)
## Multiple R-squared: 0.3105, Adjusted R-squared: 0.2313
## F-statistic: 3.919 on 10 and 87 DF, p-value: 0.0002015# musician status and personal relation are having little to no effect
m3<-update(m1, .~. + personal_relation)
summary(m3)##
## Call:
## lm(formula = absorb_mean ~ AIMS + fan + personal_relation, data = df_personal_abs)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.4418 -0.5093 -0.0525 0.4102 1.9046
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -1.418920 0.327020 -4.339 3.6e-05 ***
## AIMS 0.007269 0.002766 2.628 0.01 *
## fan 0.122285 0.029942 4.084 9.3e-05 ***
## personal_relation2 0.126491 0.195942 0.646 0.52
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.6794 on 94 degrees of freedom
## (38 observations deleted due to missingness)
## Multiple R-squared: 0.2484, Adjusted R-squared: 0.2244
## F-statistic: 10.35 on 3 and 94 DF, p-value: 5.947e-06# confirmed: personal_relation has no effect
m4<-update(m1, .~. + musician_status)
summary(m4)##
## Call:
## lm(formula = absorb_mean ~ AIMS + fan + musician_status, data = df_personal_abs)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.55841 -0.46574 -0.01919 0.46398 1.82324
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -1.177762 0.718778 -1.639 0.10484
## AIMS 0.008416 0.002998 2.808 0.00613 **
## fan 0.127967 0.030867 4.146 7.71e-05 ***
## musician_status2 -0.365137 0.739613 -0.494 0.62274
## musician_status3 -0.310048 0.709893 -0.437 0.66335
## musician_status4 -0.242817 0.722419 -0.336 0.73757
## musician_status5 -0.634469 0.734152 -0.864 0.38979
## musician_status6 -0.450938 0.763433 -0.591 0.55624
## musician_status7 -0.640419 0.738520 -0.867 0.38818
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.6836 on 89 degrees of freedom
## (38 observations deleted due to missingness)
## Multiple R-squared: 0.2795, Adjusted R-squared: 0.2148
## F-statistic: 4.316 on 8 and 89 DF, p-value: 0.0002009# try with musical non-musician as baseline.
contrasts(df_personal_abs$musician_status)<-contr.treatment(7, base = 3)
m5<-update(m1, .~. + musician_status)
summary(m5) # still no sig differences between the musician status groups##
## Call:
## lm(formula = absorb_mean ~ AIMS + fan + musician_status, data = df_personal_abs)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.55841 -0.46574 -0.01919 0.46398 1.82324
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -1.487810 0.365202 -4.074 0.00010 ***
## AIMS 0.008416 0.002998 2.808 0.00613 **
## fan 0.127967 0.030867 4.146 7.71e-05 ***
## musician_status1 0.310048 0.709893 0.437 0.66335
## musician_status2 -0.055089 0.288086 -0.191 0.84879
## musician_status4 0.067231 0.218854 0.307 0.75941
## musician_status5 -0.324421 0.230039 -1.410 0.16194
## musician_status6 -0.140890 0.321427 -0.438 0.66221
## musician_status7 -0.330371 0.239085 -1.382 0.17049
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.6836 on 89 degrees of freedom
## (38 observations deleted due to missingness)
## Multiple R-squared: 0.2795, Adjusted R-squared: 0.2148
## F-statistic: 4.316 on 8 and 89 DF, p-value: 0.0002009m6<-update(m1, .~. + EC)
summary(m6) # empathic concern is only trending as a predictor for absorption # Adjusted R-Squared = .25##
## Call:
## lm(formula = absorb_mean ~ AIMS + fan + EC, data = df_personal_abs)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.55847 -0.52486 0.00317 0.47250 1.85831
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -1.994395 0.470681 -4.237 5.28e-05 ***
## AIMS 0.005673 0.002930 1.936 0.0559 .
## fan 0.134277 0.029459 4.558 1.55e-05 ***
## EC 0.183094 0.112848 1.622 0.1080
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.6716 on 94 degrees of freedom
## (38 observations deleted due to missingness)
## Multiple R-squared: 0.2656, Adjusted R-squared: 0.2422
## F-statistic: 11.33 on 3 and 94 DF, p-value: 2.062e-06Rebuild model to make sure there are the correct number of df
df_aims_fan<-df_personal_abs%>%select(Pt_ID,group, AIMS, fan, absorb_mean)
df_aims_fan%>%filter(!is.na(absorb_mean))%>%group_by(group)%>%summarise(n())## # A tibble: 2 × 2
## group `n()`
## <fct> <int>
## 1 Live 84
## 2 Virtual 19df_aims_fan_nona<-df_aims_fan%>%filter(!is.na(absorb_mean))
m1<-lm(absorb_mean ~ AIMS + fan, data = df_aims_fan_nona)
summary(m1) # Adjusted R-Squared = .23##
## Call:
## lm(formula = absorb_mean ~ AIMS + fan, data = df_aims_fan_nona)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.47073 -0.51210 -0.01906 0.43432 1.89859
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -1.437402 0.324763 -4.426 2.56e-05 ***
## AIMS 0.007433 0.002745 2.707 0.00804 **
## fan 0.126074 0.029271 4.307 4.03e-05 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.6773 on 95 degrees of freedom
## (5 observations deleted due to missingness)
## Multiple R-squared: 0.2451, Adjusted R-squared: 0.2292
## F-statistic: 15.42 on 2 and 95 DF, p-value: 1.588e-06M1 is probably the best model. I should check AIC anyways to check whether including EC does contribute even though it isn’t significant.
anova(m1, m6)## Analysis of Variance Table
##
## Model 1: absorb_mean ~ AIMS + fan
## Model 2: absorb_mean ~ AIMS + fan + EC
## Res.Df RSS Df Sum of Sq F Pr(>F)
## 1 95 43.586
## 2 94 42.398 1 1.1874 2.6325 0.108# Model 6 is not better than model 1. # Since EC was a trending predictor when added to M1, what happens if you make a model with only fan and EC
m7<-lm(absorb_mean ~ fan + EC, data = df_personal_abs)
summary(m7) ##
## Call:
## lm(formula = absorb_mean ~ fan + EC, data = df_personal_abs)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.53926 -0.46719 -0.04636 0.45810 1.94774
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -1.73987 0.45844 -3.795 0.00026 ***
## fan 0.14693 0.02914 5.042 2.2e-06 ***
## EC 0.26397 0.10633 2.482 0.01480 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.6812 on 95 degrees of freedom
## (38 observations deleted due to missingness)
## Multiple R-squared: 0.2363, Adjusted R-squared: 0.2203
## F-statistic: 14.7 on 2 and 95 DF, p-value: 2.74e-06# now EC is a significant predictor
## what happens if AIMS is added after EC
m8<-lm(absorb_mean ~ fan + EC + AIMS, data = df_personal_abs)
summary(m8) ##
## Call:
## lm(formula = absorb_mean ~ fan + EC + AIMS, data = df_personal_abs)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.55847 -0.52486 0.00317 0.47250 1.85831
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -1.994395 0.470681 -4.237 5.28e-05 ***
## fan 0.134277 0.029459 4.558 1.55e-05 ***
## EC 0.183094 0.112848 1.622 0.1080
## AIMS 0.005673 0.002930 1.936 0.0559 .
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.6716 on 94 degrees of freedom
## (38 observations deleted due to missingness)
## Multiple R-squared: 0.2656, Adjusted R-squared: 0.2422
## F-statistic: 11.33 on 3 and 94 DF, p-value: 2.062e-06# With AIMS added after EC, EC is no longer significant and AIMS is only trending. But then 24% of the variance is explained.Step 4: Assess the model
Read the section assessing the model in the textbook. You need to assess the model to see if there are any influential cases affecting the model.
df_personal_abs_modelStats<-df_personal_abs%>%select(-personal_relation, -musician_status, -EC)%>%drop_na()
m1_modelStats<-data.frame(resid(m1), rstandard(m1))
df_personal_abs_modelStats$residuals<-resid(m1)
df_personal_abs_modelStats$standardized.residuals<- rstandard(m1)
df_personal_abs_modelStats$studentized.residuals<-rstudent(m1)
df_personal_abs_modelStats$cooks.distance<-cooks.distance(m1)
df_personal_abs_modelStats$dfbeta<-dfbeta(m1)
df_personal_abs_modelStats$dffit<-dffits(m1)
df_personal_abs_modelStats$leverage<-hatvalues(m1)
df_personal_abs_modelStats$covar.ratios<-covratio(m1)
df_personal_abs_modelStats$large.residual<-df_personal_abs_modelStats$standardized.residuals>2 | df_personal_abs_modelStats$standardized.residuals< -2
sum(df_personal_abs_modelStats$large.residual) #98 observations and 2 have large residuals. even less than expected (5%)## [1] 2df_personal_abs_modelStats[df_personal_abs_modelStats$large.residual, c("cooks.distance", "leverage", "covar.ratios")]## # A tibble: 2 × 3
## cooks.distance leverage covar.ratios
## <dbl> <dbl> <dbl>
## 1 0.0306 0.0188 0.900
## 2 0.142 0.0492 0.826# Cook's distance is no where above 1. Therefore none of them is having an undue influence on the model.
# Leverage is calculated as (k+1)/n where k is the number of IV and n is number of observations therefore average leverage is 3/98 = .03. Then items that are 2 to 3 x the leverage should be flagged, but none of them are over .06.
# Covariance ratio needs to be within certain bounds. Specifically,
# CVRi > 1 + [3(k + 1)/n] = 1 + [3(2 + 1)/98] = 1.09;
# CVRi < 1 – [3(k + 1)/n] = 1 – [3(2 + 1)/98] = 0.91.
# ADQ056 has a low covariance ratio, but the cook's distance is not alarming, therefore we don't need to worry about the low covariance so muchStep 5: Assumptions
Check whether the model meets model assumptions. From section 7.9.3 in the textbook:
Independence Assumption
Assessing the assumption of independence: Durbin Watson Test The D-W statistic should be close to 2 and if it approaches 1 or 3 that would indicate a bad result.
durbinWatsonTest(m1)## lag Autocorrelation D-W Statistic p-value
## 1 0.0847718 1.816843 0.332
## Alternative hypothesis: rho != 0Assumption of no Multicollinearity
Assessing the assumption of no Multicollinearity
vif(m1) #tolerance = 1/vif## AIMS fan
## 1.030825 1.0308251/vif(m1)## AIMS fan
## 0.9700967 0.9700967mean(vif(m1))## [1] 1.030825If the largest VIF is over 10, this is problematic. If the average VIF is substantially over 1, then the model may be biased. Tolerance below 0.1 indicates a serious problem and below 0.2 indicates a potential problem.
Assumptions about the residuals
Can be examined visually
plot(m1)
# residuals vs fitted plot looks good. no evidence of heteroscedasticity or linearity.
# QQplot shows little to no deviations from normality
hist(df_personal_abs_modelStats$studentized.residuals)
# looks pretty normalSummary
The model appears to be both accurate for the sample and generalizable to the population.
The best model for explaining the influence of individual characteristics on absorption contains AIMS and fan-status as significant predictors. Together they explain 23% of the variance. The AIMS is a personality scale that measures participants’ typical absorption with music. Fan-status was an even stronger predictor of absorption than AIMS.
summary(m1)##
## Call:
## lm(formula = absorb_mean ~ AIMS + fan, data = df_aims_fan_nona)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.47073 -0.51210 -0.01906 0.43432 1.89859
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -1.437402 0.324763 -4.426 2.56e-05 ***
## AIMS 0.007433 0.002745 2.707 0.00804 **
## fan 0.126074 0.029271 4.307 4.03e-05 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.6773 on 95 degrees of freedom
## (5 observations deleted due to missingness)
## Multiple R-squared: 0.2451, Adjusted R-squared: 0.2292
## F-statistic: 15.42 on 2 and 95 DF, p-value: 1.588e-063.5.1 Absorption ~ Group + Piece
3.5 What is the influence of social context (group: Live, Livestreaming) and the piece of music (Beethoven, Schnittke, Folk) on musical absorption and mind-wandering?
Linear mixed effects modeling
- Organize the data
dat<-df.full%>%select(Pt_ID, group,contains("Absorption"))
df.long<-dat%>%pivot_longer(!c(group, Pt_ID), #make long
names_to = c("piece"),
names_pattern ="_(.*)",
values_to = "Absorption")
df.long<-df.long%>%filter(! piece == "Bach")
df.long$piece<-factor(df.long$piece, levels = c("Beethoven", "Schnittke", "Bach", "Folk"))
#factor for the correct facet order
data<-df.long%>%drop_na() #408 to 359Outliers
Remove extreme outliers from Absorption measure. None are extreme.
outliers<-data %>%
group_by(group, piece) %>%
identify_outliers(Absorption)
outliers # 1; None are extreme.## # A tibble: 1 × 6
## group piece Pt_ID Absorption is.outlier is.extreme
## <fct> <fct> <chr> <dbl> <lgl> <lgl>
## 1 Live Schnittke ADQ003 -2.79 TRUE FALSEextreme<-outliers%>%filter(is.extreme == TRUE)
extreme # none are extreme## # A tibble: 0 × 6
## # … with 6 variables: group <fct>, piece <fct>, Pt_ID <chr>, Absorption <dbl>,
## # is.outlier <lgl>, is.extreme <lgl># remove specific instances that are outliers (Pt_ID and piece, because lme can handle missing data so you don't need to remove the whole participant)
# data uten outliers
data_u_outliers<-data%>% # 359 to 358 : looks good!
group_by(group, piece) %>%
filter(!is_outlier(Absorption))%>%
ungroup()
# data uten extreme
data_u_extreme<-data%>% # 359 to 359 : looks good!
group_by(group, piece) %>%
filter(!is_extreme(Absorption))%>%
ungroup()Model testing
Andy Field wrote a textbook titled Discovering Statistics using R. In chapter 14, he covers the topic of mixed designs (GLM 5) and explains how to use nlme to analyse a mixed design. I will use the information presented in the textbook as an approach for examining the influence of piece (repeated measures: factor) and group (between subjects: factor) on musical absorption (continuous).
With random intercept of Pt_ID (as opposed to Pt_ID nested in piece)
nl_baseline<-lme(Absorption ~ 1, random = ~1|Pt_ID, data = data, method = "ML") # ML = maximum likelihood estimate
nl_groupM<-update(nl_baseline, .~. +group) # sig
nl_pieceM<-update(nl_groupM, .~. +piece) # sig
nl_group_piece<-update(nl_pieceM, .~. +group:piece) # NS
anova(nl_baseline, nl_groupM, nl_pieceM, nl_group_piece)## Model df AIC BIC logLik Test L.Ratio p-value
## nl_baseline 1 3 963.1773 974.8272 -478.5886
## nl_groupM 2 4 957.4796 973.0129 -474.7398 1 vs 2 7.697676 0.0055
## nl_pieceM 3 6 943.3529 966.6529 -465.6765 2 vs 3 18.126638 0.0001
## nl_group_piece 4 8 947.2607 978.3273 -465.6303 3 vs 4 0.092260 0.9549#summary(nl_pieceM)
## With lme4
### data_uten_extreme is the exact same data set so it is fine to use data here.
baseline<-lmer(Absorption ~ 1 + (1|Pt_ID), data = data, REML = FALSE) # ML = maximum likelihood estimate
groupM<-lmer(Absorption ~ group + (1|Pt_ID), data = data, REML = FALSE) # ML = maximum likelihood estimate
pieceM<-lmer(Absorption ~ group + piece + (1|Pt_ID), data = data, REML = FALSE) # ML = maximum likelihood estimate
piece_x_groupM<-lmer(Absorption ~ group * piece + (1|Pt_ID), data = data, REML = FALSE) # ML = maximum likelihood estimate
anova(baseline, groupM, pieceM, piece_x_groupM)## Data: data
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## groupM: Absorption ~ group + (1 | Pt_ID)
## pieceM: Absorption ~ group + piece + (1 | Pt_ID)
## piece_x_groupM: Absorption ~ group * piece + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 963.18 974.83 -478.59 957.18
## groupM 4 957.48 973.01 -474.74 949.48 7.6977 1 0.0055292 **
## pieceM 6 943.35 966.65 -465.68 931.35 18.1266 2 0.0001158 ***
## piece_x_groupM 8 947.26 978.33 -465.63 931.26 0.0923 2 0.9549179
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1There were significant main effects of group, X2(1) = 7.70, p = .006, and piece, X2(2) = 18.13, p .0001, on musical absorption. However there was no significant interaction effect between group and piece, X2(2) = .09, p = .95.
Check model assumptions
What are the assumptions of lme and how to check them? They are the same as linear regression in general and include: 1) explanatory variables are related linearly to the response. In my case, my vars are not continuous and thus maybe a mixed anova would be better for explaining things anyways. However it is OK to dummy code and do a multilevel modeling approach. 2) errors have a constant variance 3) errors are independent 4) errors are normally distributed
“check the assumptions that the 1) errors are normally distributed and that the 2) random effects are normally distributed”
Here is a tutorial that was recommended: https://bodowinter.com/tutorial/bw_LME_tutorial1.pdf https://bodowinter.com/tutorial/bw_LME_tutorial2.pdf
Model assumptions of linearity and homoscedasticity were checked by visually inspecting the fitted versus residual plot. The assumption of normal residuals was visually inspected with a QQplot of the residuals.
Linearity Because there is no obvious pattern in the residuals, it seems like there is no violation of the linearity assumption.
plot(pieceM) # this looks quite good
Absence of Collinearity If two fixed effects preditors are
correlated with each other, they are said to be collinear. Not possible
in this case (with factors only, and no reason they should be
related)
Homoskedasticity This doesn’t appear obviously heteroscedastic but it isn’t perfect either.
Normality of residuals “The normality of residuals
assumption is the one that is least important. Interestingly, many
people seem to think it is the most important one, but it turns
out that linear models are relatively robust against violations of the
assumptions of normality. Researchers differ with respect to how much
weight they put onto
checking this assumption. For example, Gellman and Hill (2007), a famous
book on linear models and mixed models, do not even recommend
diagnostics of the normality assumption (ibid. 46).”
# The histogram looks skewed with a negative tail.
hist(residuals(pieceM))
qqnorm(residuals(pieceM))
require(lattice)## Loading required package: latticeqqmath(pieceM, id=0.05) #id: identifies values that may be exerting undue influence on the model (i.e. outliers)
This model seems fine, however the explanatory variables group and piece aren’t really related linearly simply because group and piece are factors. Therefore you could do a mixed ANOVA instead and check the assumptions there.
Pairwise comparisons
There were significant main effects of group, X2(1) = 7.70, p = .006, and piece, X2(2) = 18.13, p .0001, on musical absorption. However there was no significant interaction effect between group and piece, X2(2) = .09, p = .95. Pairwise comparisons were conducted with estimated marginal means and indicated that musical absorption was greater for the live than the livestreaming audience, b = .41, t(145) = 2.71, p = .0075, and during folk than during Beethoven, b = .39, t(240) = 4.08, p = .0002, and Schnittke, b = .31, t(237) = 3.26, p = .003.
emmeans(pieceM, pairwise ~ piece) # estimated marginal means## $emmeans
## piece emmean SE df lower.CL upper.CL
## Beethoven -0.268 0.0911 272 -0.4470 -0.08842
## Schnittke -0.191 0.0934 283 -0.3750 -0.00712
## Folk 0.120 0.0938 285 -0.0647 0.30460
##
## Results are averaged over the levels of: group
## Degrees-of-freedom method: kenward-roger
## Confidence level used: 0.95
##
## $contrasts
## contrast estimate SE df t.ratio p.value
## Beethoven - Schnittke -0.0767 0.0945 239 -0.811 0.6966
## Beethoven - Folk -0.3877 0.0951 240 -4.078 0.0002
## Schnittke - Folk -0.3110 0.0954 237 -3.259 0.0037
##
## Results are averaged over the levels of: group
## Degrees-of-freedom method: kenward-roger
## P value adjustment: tukey method for comparing a family of 3 estimates# comparison: Absorption is greater in Folk than in Beethoven or Schnittke
emmeans(pieceM, pairwise ~ group) # estimated marginal means## $emmeans
## group emmean SE df lower.CL upper.CL
## Live 0.090 0.0806 126 -0.0695 0.2495
## Virtual -0.316 0.1261 153 -0.5650 -0.0667
##
## Results are averaged over the levels of: piece
## Degrees-of-freedom method: kenward-roger
## Confidence level used: 0.95
##
## $contrasts
## contrast estimate SE df t.ratio p.value
## Live - Virtual 0.406 0.15 145 2.711 0.0075
##
## Results are averaged over the levels of: piece
## Degrees-of-freedom method: kenward-roger# comparison: Absorption was greater for the live group than the livestreaming group.Mixed ANOVA
dat<-df.full%>%select(Pt_ID, group,contains("Absorption"))
df.long<-dat%>%pivot_longer(!c(group, Pt_ID), #make long
names_to = c("piece"),
names_pattern ="_(.*)",
values_to = "Absorption")
df.long$piece<-factor(df.long$piece, levels = c("Beethoven", "Schnittke", "Bach", "Folk"))
#factor for the correct facet order
data<-df.long%>%drop_na() #408 to 359
data%>%group_by(piece)%>%summarize(n())## # A tibble: 3 × 2
## piece `n()`
## <fct> <int>
## 1 Beethoven 123
## 2 Schnittke 119
## 3 Folk 117I followed this tutorial: https://www.datanovia.com/en/lessons/mixed-anova-in-r/
IV1: group, IV2: piece, DV: Absorption factor score
data %>%
group_by(group, piece) %>%
get_summary_stats(Absorption, type = "mean_sd")## # A tibble: 6 × 6
## group piece variable n mean sd
## <fct> <fct> <chr> <dbl> <dbl> <dbl>
## 1 Live Beethoven Absorption 87 -0.043 0.952
## 2 Live Schnittke Absorption 90 0.006 1.03
## 3 Live Folk Absorption 88 0.302 0.904
## 4 Virtual Beethoven Absorption 36 -0.572 0.965
## 5 Virtual Schnittke Absorption 29 -0.378 0.921
## 6 Virtual Folk Absorption 29 0.04 1.01bxp <- ggboxplot(
data, x = "piece", y = "Absorption",
color = "group", palette = "jco"
)
bxp
### Check assumptions #### Outliers ADQ003 is an outlier, though not
extreme
outliers<-data %>%
group_by(group, piece) %>%
identify_outliers(Absorption)
outliers## # A tibble: 1 × 6
## group piece Pt_ID Absorption is.outlier is.extreme
## <fct> <fct> <chr> <dbl> <lgl> <lgl>
## 1 Live Schnittke ADQ003 -2.79 TRUE FALSEConsider removing the outliers and try the tests again
#data<-data%>%filter(! Pt_ID %in% outliers$Pt_ID)Normality assumption
Normality can be tested with the stringent Shapiro test or with a more lenient visual inspection.
Violated for the folk piece - p = .004 Possibly because everyone was so absorbed in the folk.
However: “Note that, if your sample size is greater than 50, the normal QQ plot is preferred because at larger sample sizes the Shapiro-Wilk test becomes very sensitive even to a minor deviation from normality.”
“QQ plot draws the correlation between a given data and the normal distribution.”
# Shapiro test
data %>%
group_by(group, piece) %>%
shapiro_test(Absorption) ## # A tibble: 6 × 5
## group piece variable statistic p
## <fct> <fct> <chr> <dbl> <dbl>
## 1 Live Beethoven Absorption 0.976 0.0988
## 2 Live Schnittke Absorption 0.974 0.0721
## 3 Live Folk Absorption 0.955 0.00412
## 4 Virtual Beethoven Absorption 0.981 0.792
## 5 Virtual Schnittke Absorption 0.975 0.690
## 6 Virtual Folk Absorption 0.951 0.198QQplots do not look horrible. There is deviation only at the ends. “All the points fall approximately along the reference line, for each cell. So we can assume normality of the data.”
# QQPlot
ggqqplot(data, "Absorption", ggtheme = theme_bw()) +
facet_grid(piece ~ group)
Homogeneity of variance assumption
Levene’s test - none are significant
data %>%
group_by(piece) %>%
levene_test(Absorption ~ group)## # A tibble: 3 × 5
## piece df1 df2 statistic p
## <fct> <int> <int> <dbl> <dbl>
## 1 Beethoven 1 121 0.157 0.692
## 2 Schnittke 1 117 0.497 0.482
## 3 Folk 1 115 0.460 0.499Homogeneity of covariances assumption
NS test therefore assumption is satisfied
box_m(data[, "Absorption", drop = FALSE], data$group)## # A tibble: 1 × 4
## statistic p.value parameter method
## <dbl> <dbl> <dbl> <chr>
## 1 0.0432 0.835 1 Box's M-test for Homogeneity of Covariance Matric…Assumption of sphericity
is checked naturally with anova_test
Test
# Two-way mixed ANOVA test
res.aov <- anova_test(
data = data, dv = Absorption, wid = Pt_ID,
between = group, within = piece
)
get_anova_table(res.aov)## ANOVA Table (type III tests)
##
## Effect DFn DFd F p p<.05 ges
## 1 group 1 101 4.009 0.048 * 0.024
## 2 piece 2 202 2.746 0.067 0.010
## 3 group:piece 2 202 0.426 0.654 0.002Piece effect became less significant with the removal of the outlier. If these tests were conducted as linear mixed effects models, then there would be an effect of group AND piece. This may be caused by improper modeling of the random effects though and using mixed ANOVAs are recommended over lme when possible (Arnqvist, 2020).
# Pairwise comparisons between group levels
pwc <- data %>%
group_by(piece) %>%
pairwise_t_test(Absorption ~ group, p.adjust.method = "bonferroni")
pwc## # A tibble: 3 × 10
## piece .y. group1 group2 n1 n2 p p.signif p.adj p.adj.signif
## * <fct> <chr> <chr> <chr> <int> <int> <dbl> <chr> <dbl> <chr>
## 1 Beethov… Abso… Live Virtu… 87 36 0.00611 ** 0.00611 **
## 2 Schnitt… Abso… Live Virtu… 90 29 0.076 ns 0.076 ns
## 3 Folk Abso… Live Virtu… 88 29 0.19 ns 0.19 nsVisualize
colours_DSQ<-c("#2d769a","#b34036")
#update group label
data$group<-factor(data$group, levels = c("Live", "Virtual"), labels = c("Live", "Livestreaming"))
# BOXPLOT
data%>%ggplot(aes(x = group, y = Absorption, fill = group))+
geom_boxplot()+
facet_grid(cols = vars(piece))+
labs(title = "Effect of Piece and Group on Absorption",y = "Absorption Score", x = "")+
scale_fill_manual(values= colours_DSQ, name = "Concert Group")+
theme_DSQ()+
theme(legend.position='None')## Warning in grid.Call(C_stringMetric, as.graphicsAnnot(x$label)): font family not
## found in Windows font database## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database## Warning in grid.Call(C_stringMetric, as.graphicsAnnot(x$label)): font family not
## found in Windows font database
## Warning in grid.Call(C_stringMetric, as.graphicsAnnot(x$label)): font family not
## found in Windows font database## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database## Warning in grid.Call.graphics(C_text, as.graphicsAnnot(x$label), x$x, x$y, :
## font family not found in Windows font database## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
graphname<-paste0("../plots/Absorption-by-piece-Group.png")
ggsave(graphname, width = 15, height = 10, units = 'cm', dpi = 500)
## DOTPLOT
dot<-ggdotplot(data, x = "group", y = "Absorption", fill = "group", facet.by = "piece", add = "mean_sd")+
labs(title = "Effect of Group and Piece on Absorption",y = "Absorption Score", x = "")+
scale_fill_manual(values = colours_DSQ, name = "Concert Group")+
theme_DSQ()+
theme(legend.position='None')
dot## Bin width defaults to 1/30 of the range of the data. Pick better value with `binwidth`.## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database## Warning in grid.Call.graphics(C_text, as.graphicsAnnot(x$label), x$x, x$y, :
## font family not found in Windows font database## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
graphname<-paste0("../plots/Absorption-by-piece-Group_dot.png")
ggsave(graphname,
width = 17,
height = 10,
units = 'cm',
dpi = 500)## Bin width defaults to 1/30 of the range of the data. Pick better value with `binwidth`.## DOTPLOT
dot<-ggdotplot(data, x = "group", y = "Absorption", fill = "group", facet.by = "piece", add = "mean_sd")+
labs(title = "Effect of Group on Absorption",y = "Absorption Score", x = "")+
scale_fill_manual(values = colours_DSQ, name = "Concert Group")+
theme_DSQ()+
theme(legend.position='None')
dot## Bin width defaults to 1/30 of the range of the data. Pick better value with `binwidth`.## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database## Warning in grid.Call.graphics(C_text, as.graphicsAnnot(x$label), x$x, x$y, :
## font family not found in Windows font database## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
# I don't want to add the pwc sig anymore because there was no interaction.
pwc<-pwc%>%add_xy_position(x = "group")
pwc$y.position<-pwc$y.position+.3
# add significance value to plot
dot+stat_pvalue_manual(pwc, hide.ns = TRUE)#, label = "p.adj.signif")## Bin width defaults to 1/30 of the range of the data. Pick better value with `binwidth`.## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database## Warning in grid.Call.graphics(C_text, as.graphicsAnnot(x$label), x$x, x$y, :
## font family not found in Windows font database## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
graphname<-paste0("../plots/Absorption-by-piece-Group_dot.png")
ggsave(graphname,
width = 17,
height = 10,
units = 'cm',
dpi = 500)## Bin width defaults to 1/30 of the range of the data. Pick better value with `binwidth`.## To represent that there was only a main effect of group, I should average across pieces and only show the group difference.
## DOTPLOT
group<-data%>%select(group, Pt_ID)%>%unique()
avg<-data%>%group_by(Pt_ID)%>%summarise(Absorption = mean(Absorption))%>%full_join(group,by = "Pt_ID")
dot<-ggdotplot(avg, x = "group", y = "Absorption", fill = "group", add = "mean_sd")+
labs(title = "Effect of Group on Absorption",y = "Absorption Score", x = "")+
scale_fill_manual(values = colours_DSQ, name = "Concert Group")+
theme_minimal()+
theme(legend.position='None')+
# add significance value to plot
geom_signif(comparisons = list(c("Live", "Livestreaming")),
annotation = "*", vjust = .5)
dot## Bin width defaults to 1/30 of the range of the data. Pick better value with `binwidth`.
graphname<-paste0("../plots/Absorption-by-Group_dot.png")
ggsave(graphname,
width = 8,
height = 10,
units = 'cm',
dpi = 500)## Bin width defaults to 1/30 of the range of the data. Pick better value with `binwidth`.Effect of group on Absorption dotplot
Try making a visualization where it is faceted by group so you show each piece separately on either side of a facet, then edit the image in powerpoint to show the significant group difference across facets.
This is the figure included in the manuscript.
## DOTPLOT - facet by group
dot<-ggdotplot(data, x = "piece", y = "Absorption", fill = "group", facet.by = "group", add = "mean_sd")+
labs(title = "Effect of Group on Absorption",y = "Absorption Score", x = "")+
scale_fill_manual(values = colours_DSQ, name = "Concert Group")+
ylim(-3,2.3)+
theme_minimal()+
theme(legend.position='None')
dot## Bin width defaults to 1/30 of the range of the data. Pick better value with `binwidth`.
graphname<-paste0("../plots/Absorption-facet-by-Group_dot.png")
ggsave(graphname, width = 17, height = 10, units = 'cm', dpi = 500)## Bin width defaults to 1/30 of the range of the data. Pick better value with `binwidth`.3.5.2 Mind-Wandering ~ Group & Piece
Linear mixed effects modeling
- Organize the data
# Organize data
dat<-df.full%>%select(Pt_ID, group,contains("Mind-wandering"))
df.long<-dat%>%pivot_longer(!c(group, Pt_ID), #make long
names_to = c("piece"),
names_pattern ="_(.*)",
values_to = "Mindwandering")
df.long<-df.long%>%filter(! piece == "Bach")
df.long$piece<-factor(df.long$piece, levels = c("Beethoven", "Schnittke", "Bach", "Folk"))
#factor for the correct facet order
data<-df.long%>%drop_na() #408 to 359Outliers
outliers<-data %>%
group_by(group, piece) %>%
identify_outliers(Mindwandering)
outliers # 9; 5 are extreme.## # A tibble: 9 × 6
## group piece Pt_ID Mindwandering is.outlier is.extreme
## <fct> <fct> <chr> <dbl> <lgl> <lgl>
## 1 Live Folk ADS072 1.93 TRUE FALSE
## 2 Virtual Folk BEQ099 -2.13 TRUE TRUE
## 3 Virtual Folk BES121 -1.77 TRUE FALSE
## 4 Virtual Folk BEQ101 -1.38 TRUE FALSE
## 5 Virtual Folk BEU126 2.04 TRUE TRUE
## 6 Virtual Folk BEQ105 -1.88 TRUE TRUE
## 7 Virtual Folk BnS136 2.05 TRUE TRUE
## 8 Virtual Folk BnS134 1.57 TRUE FALSE
## 9 Virtual Folk BEQ102 -1.99 TRUE TRUEextreme<-outliers%>%filter(is.extreme == TRUE)
extreme # 5 are extreme## # A tibble: 5 × 6
## group piece Pt_ID Mindwandering is.outlier is.extreme
## <fct> <fct> <chr> <dbl> <lgl> <lgl>
## 1 Virtual Folk BEQ099 -2.13 TRUE TRUE
## 2 Virtual Folk BEU126 2.04 TRUE TRUE
## 3 Virtual Folk BEQ105 -1.88 TRUE TRUE
## 4 Virtual Folk BnS136 2.05 TRUE TRUE
## 5 Virtual Folk BEQ102 -1.99 TRUE TRUE# remove specific instances that are outliers (Pt_ID and piece, because lme can handle missing data so you don't need to remove the whole participant)
# data uten outliers
data_u_outliers<-data%>% # 359 to 350 : looks good!
group_by(group, piece) %>%
filter(!is_outlier(Mindwandering))%>%
ungroup()
# data uten extreme
data_u_extreme<-data%>% # 359 to 354 : looks good!
group_by(group, piece) %>%
filter(!is_extreme(Mindwandering))%>%
ungroup()Model testing
Random intercept of participant
## With lme4
baseline<-lmer(Mindwandering ~ 1 + (1|Pt_ID), data = data, REML = FALSE) # ML = maximum likelihood estimate
groupM<-lmer(Mindwandering ~ group + (1|Pt_ID), data = data, REML = FALSE) # ML = maximum likelihood estimate
pieceM<-lmer(Mindwandering ~ group + piece + (1|Pt_ID), data = data, REML = FALSE) # ML = maximum likelihood estimate
piece_x_groupM<-lmer(Mindwandering ~ group * piece + (1|Pt_ID), data = data, REML = FALSE) # ML = maximum likelihood estimate
anova(baseline, groupM, pieceM, piece_x_groupM)## Data: data
## Models:
## baseline: Mindwandering ~ 1 + (1 | Pt_ID)
## groupM: Mindwandering ~ group + (1 | Pt_ID)
## pieceM: Mindwandering ~ group + piece + (1 | Pt_ID)
## piece_x_groupM: Mindwandering ~ group * piece + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 938.95 950.60 -466.48 932.95
## groupM 4 937.22 952.75 -464.61 929.22 3.7361 1 0.05325 .
## pieceM 6 882.67 905.97 -435.33 870.67 58.5498 2 1.932e-13 ***
## piece_x_groupM 8 883.85 914.91 -433.92 867.85 2.8200 2 0.24415
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1##Refit with only sig effects
baseline<-lmer(Mindwandering ~ 1 + (1|Pt_ID), data = data, REML = FALSE) # ML = maximum likelihood estimate
pieceM<-lmer(Mindwandering ~ piece + (1|Pt_ID), data = data, REML = FALSE) # ML = maximum likelihood estimate
groupM<-lmer(Mindwandering ~ group + piece + (1|Pt_ID), data = data, REML = FALSE) # ML = maximum likelihood estimate
piece_x_groupM<-lmer(Mindwandering ~ group * piece + (1|Pt_ID), data = data, REML = FALSE) # ML = maximum likelihood estimate
anova(baseline, pieceM,groupM, piece_x_groupM)## Data: data
## Models:
## baseline: Mindwandering ~ 1 + (1 | Pt_ID)
## pieceM: Mindwandering ~ piece + (1 | Pt_ID)
## groupM: Mindwandering ~ group + piece + (1 | Pt_ID)
## piece_x_groupM: Mindwandering ~ group * piece + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 938.95 950.60 -466.48 932.95
## pieceM 5 883.74 903.15 -436.87 873.74 59.2155 2 1.385e-13 ***
## groupM 6 882.67 905.97 -435.33 870.67 3.0704 1 0.07973 .
## piece_x_groupM 8 883.85 914.91 -433.92 867.85 2.8200 2 0.24415
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1There was a significant main effect of piece, χ2(2) = 59.2, p < .0001, however there was no significant effect of group, χ2(1) = 3.07, p = .080, or interaction between piece and group, χ2(2) = 2.82, p = .24, on musical absorption.
Try without extreme outliers. Including or excluding the extreme outliers did not change the model assumptions being satisfied nor did it change the significance of the main effect, therefore the extreme outliers were retained for this analysis.
##Refit with only sig effects
baseline<-lmer(Mindwandering ~ 1 + (1|Pt_ID), data = data_u_extreme, REML = FALSE) # ML = maximum likelihood estimate
pieceM<-lmer(Mindwandering ~ piece + (1|Pt_ID), data = data_u_extreme, REML = FALSE) # ML = maximum likelihood estimate
groupM<-lmer(Mindwandering ~ group + piece + (1|Pt_ID), data = data_u_extreme, REML = FALSE) # ML = maximum likelihood estimate
piece_x_groupM<-lmer(Mindwandering ~ group * piece + (1|Pt_ID), data = data_u_extreme, REML = FALSE) # ML = maximum likelihood estimate
anova(baseline, pieceM,groupM, piece_x_groupM)## Data: data_u_extreme
## Models:
## baseline: Mindwandering ~ 1 + (1 | Pt_ID)
## pieceM: Mindwandering ~ piece + (1 | Pt_ID)
## groupM: Mindwandering ~ group + piece + (1 | Pt_ID)
## piece_x_groupM: Mindwandering ~ group * piece + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 920.39 932.00 -457.20 914.39
## pieceM 5 865.99 885.34 -428.00 855.99 58.4025 2 2.08e-13 ***
## groupM 6 865.17 888.39 -426.59 853.17 2.8206 1 0.09306 .
## piece_x_groupM 8 866.39 897.34 -425.19 850.39 2.7825 2 0.24876
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1There were significant main effects of group, X2(1) = 7.70, p = .006, and piece, X2(2) = 18.13, p .0001, on musical absorption. However there was no significant interaction effect between group and piece, X2(2) = .09, p = .95.
Check model assumptions
What are the assumptions of lme and how to check them? They are the same as linear regression in general and include: 1) explanatory variables are related linearly to the response. In my case, my vars are not continuous and thus maybe a mixed anova would be better for explaining things anyways. However it is OK to dummy code and do a multilevel modeling approach. 2) errors have a constant variance 3) errors are independent 4) errors are normally distributed
“check the assumptions that the 1) errors are normally distributed and that the 2) random effects are normally distributed”
Here is a tutorial that was recommended: https://bodowinter.com/tutorial/bw_LME_tutorial1.pdf https://bodowinter.com/tutorial/bw_LME_tutorial2.pdf
Model assumptions of linearity and homoscedasticity were checked by visually inspecting the fitted versus residual plot. The assumption of normal residuals was visually inspected with a QQplot of the residuals. Even without excluding the 5 extreme outliers, the model looked like it satisfied all assumptions.
Including or excluding the extreme outliers did not change the model assumptions being satisfied nor did it change the significance of the main effect, therefore the extreme outliers were retained for this analysis.
Linearity Because there is no obvious pattern in the residuals, it seems like there is no violation of the linearity assumption.
plot(pieceM) # this looks quite good
Absence of Collinearity If two fixed effects preditors are
correlated with each other, they are said to be collinear. Not possible
in this case (with factors only, and no reason they should be
related)
Homoskedasticity This doesn’t appear obviously heteroscedastic but it isn’t perfect either.
Normality of residuals “The normality of residuals
assumption is the one that is least important. Interestingly, many
people seem to think it is the most important one, but it turns
out that linear models are relatively robust against violations of the
assumptions of normality. Researchers differ with respect to how much
weight they put onto
checking this assumption. For example, Gellman and Hill (2007), a famous
book on linear models and mixed models, do not even recommend
diagnostics of the normality assumption (ibid. 46).”
# The histogram looks good
hist(residuals(pieceM))
qqnorm(residuals(pieceM)) # good
require(lattice)
qqmath(pieceM, id=0.05) #id: identifies values that may be exerting undue influence on the model (i.e. outliers)
This model seems fine, however the explanatory variables group and piece aren’t really related linearly simply because group and piece are factors. Therefore you could do a mixed ANOVA instead and check the assumptions there.
Pairwise comparisons
There was a significant main effect of piece, χ2(2) = 59.2, p < .0001, however there was no significant effect of group, χ2(1) = 3.07, p = .080, or interaction between piece and group, χ2(2) = 2.82, p = .24, on mind-wandering. Pairwise comparisons were conducted with estimated marginal means and indicated that mind-wandering was greater during the Beethoven than the Schnittke, b = .41, t(236) = 5.09, p < .0001, or the Folk, b = .65, t(237) = 8.06, p <.0001, and greater during the Schnittke than the Folk, b = .24, t(234) = 2.99, p = .0087.
emmeans(pieceM, pairwise ~ piece) # estimated marginal means## $emmeans
## piece emmean SE df lower.CL upper.CL
## Beethoven 0.3483 0.0843 235 0.182 0.514
## Schnittke -0.0613 0.0852 241 -0.229 0.107
## Folk -0.3032 0.0868 251 -0.474 -0.132
##
## Degrees-of-freedom method: kenward-roger
## Confidence level used: 0.95
##
## $contrasts
## contrast estimate SE df t.ratio p.value
## Beethoven - Schnittke 0.410 0.0799 232 5.123 <.0001
## Beethoven - Folk 0.652 0.0815 233 7.991 <.0001
## Schnittke - Folk 0.242 0.0818 231 2.957 0.0096
##
## Degrees-of-freedom method: kenward-roger
## P value adjustment: tukey method for comparing a family of 3 estimates# comparison: Absorption is greater in Folk than in Beethoven or SchnittkeMixed ANOVA
First, organize data
# Organize data
dat<-df.full%>%select(Pt_ID, group,contains("Mind-wandering"))
df.long<-dat%>%pivot_longer(!c(group, Pt_ID), #make long
names_to = c("piece"),
names_pattern ="_(.*)",
values_to = "Mindwandering")
df.long$piece<-factor(df.long$piece, levels = c("Beethoven", "Schnittke", "Bach", "Folk"))
#factor for the correct facet order
data<-df.long%>%drop_na() #408 to 359IV1: group, IV2: piece, DV: Mind-wandering factor score
The boxplot definitely raises suspicions that these could be different.
data %>%
group_by(group, piece) %>%
get_summary_stats(Mindwandering, type = "mean_sd")## # A tibble: 6 × 6
## group piece variable n mean sd
## <fct> <fct> <chr> <dbl> <dbl> <dbl>
## 1 Live Beethoven Mindwandering 87 0.334 1.04
## 2 Live Schnittke Mindwandering 90 -0.151 0.937
## 3 Live Folk Mindwandering 88 -0.379 0.868
## 4 Virtual Beethoven Mindwandering 36 0.343 0.904
## 5 Virtual Schnittke Mindwandering 29 0.081 1.08
## 6 Virtual Folk Mindwandering 29 -0.081 1.06bxp <- ggboxplot(
data, x = "piece", y = "Mindwandering",
color = "group", palette = "jco"
)
bxp
Check assumptions
Outliers
There are several outliers on the measure of mind-wandering, 5 that are extreme, 4 in the positive direction and 5 in the negative direction. 8/9 are from the virtual group.
outliers<-data %>%
group_by(group, piece) %>%
identify_outliers(Mindwandering)
outliers## # A tibble: 9 × 6
## group piece Pt_ID Mindwandering is.outlier is.extreme
## <fct> <fct> <chr> <dbl> <lgl> <lgl>
## 1 Live Folk ADS072 1.93 TRUE FALSE
## 2 Virtual Folk BEQ099 -2.13 TRUE TRUE
## 3 Virtual Folk BES121 -1.77 TRUE FALSE
## 4 Virtual Folk BEQ101 -1.38 TRUE FALSE
## 5 Virtual Folk BEU126 2.04 TRUE TRUE
## 6 Virtual Folk BEQ105 -1.88 TRUE TRUE
## 7 Virtual Folk BnS136 2.05 TRUE TRUE
## 8 Virtual Folk BnS134 1.57 TRUE FALSE
## 9 Virtual Folk BEQ102 -1.99 TRUE TRUEextreme<-outliers%>%filter(is.extreme == TRUE)%>%select(Pt_ID)Data uten extreme: data_u_extreme
data_u_extreme<-data%>%filter(!Pt_ID %in% extreme$Pt_ID)Normality assumption
Violated for the virtual group and folk piece - p = .04
However: “Note that, if your sample size is greater than 50, the normal QQ plot is preferred because at larger sample sizes the Shapiro-Wilk test becomes very sensitive even to a minor deviation from normality.”
“QQ plot draws the correlation between a given data and the normal distribution.”
#### shapiro test
data %>% # sig test for virtual folk
group_by(group, piece) %>%
shapiro_test(Mindwandering)## # A tibble: 6 × 5
## group piece variable statistic p
## <fct> <fct> <chr> <dbl> <dbl>
## 1 Live Beethoven Mindwandering 0.976 0.112
## 2 Live Schnittke Mindwandering 0.976 0.0873
## 3 Live Folk Mindwandering 0.980 0.202
## 4 Virtual Beethoven Mindwandering 0.980 0.758
## 5 Virtual Schnittke Mindwandering 0.970 0.557
## 6 Virtual Folk Mindwandering 0.926 0.0433data_u_extreme %>% # NS
group_by(group, piece) %>%
shapiro_test(Mindwandering)## # A tibble: 6 × 5
## group piece variable statistic p
## <fct> <fct> <chr> <dbl> <dbl>
## 1 Live Beethoven Mindwandering 0.976 0.112
## 2 Live Schnittke Mindwandering 0.976 0.0873
## 3 Live Folk Mindwandering 0.980 0.202
## 4 Virtual Beethoven Mindwandering 0.978 0.743
## 5 Virtual Schnittke Mindwandering 0.975 0.768
## 6 Virtual Folk Mindwandering 0.922 0.0661This does not look horrible. There is deviation only at the ends. “All the points fall approximately along the reference line, for each cell. So we can assume normality of the data.”
#### QQPlot
ggqqplot(data, "Mindwandering", ggtheme = theme_bw()) +
facet_grid(piece ~ group)
ggqqplot(data_u_extreme, "Mindwandering", ggtheme = theme_bw()) +
facet_grid(piece ~ group)
#### Homogeneity of variance assumption Levene’s test - - removing the
extreme outliers caused this test to be significant in the folk.
data %>%
group_by(piece) %>%
levene_test(Mindwandering ~ group) # none significant## # A tibble: 3 × 5
## piece df1 df2 statistic p
## <fct> <int> <int> <dbl> <dbl>
## 1 Beethoven 1 121 0.562 0.455
## 2 Schnittke 1 117 0.802 0.372
## 3 Folk 1 115 0.0609 0.805data_u_extreme %>%
group_by(piece) %>%
levene_test(Mindwandering ~ group) # significant in the folk## # A tibble: 3 × 5
## piece df1 df2 statistic p
## <fct> <int> <int> <dbl> <dbl>
## 1 Beethoven 1 117 1.59 0.210
## 2 Schnittke 1 113 0.0420 0.838
## 3 Folk 1 110 3.97 0.0488Homogeneity of covariances assumption
NS test therefore assumption is satisfied
box_m(data[, "Mindwandering", drop = FALSE], data$group) #p = .81## # A tibble: 1 × 4
## statistic p.value parameter method
## <dbl> <dbl> <dbl> <chr>
## 1 0.0545 0.815 1 Box's M-test for Homogeneity of Covariance Matric…box_m(data_u_extreme[, "Mindwandering", drop = FALSE], data_u_extreme$group) # p = .07## # A tibble: 1 × 4
## statistic p.value parameter method
## <dbl> <dbl> <dbl> <chr>
## 1 3.08 0.0793 1 Box's M-test for Homogeneity of Covariance Matric…Assumption of sphericity
is checked naturally with anova_test
Test
# Two-way mixed ANOVA test
res.aov <- anova_test(
data = data, dv = Mindwandering, wid = Pt_ID,
between = group, within = piece
)
get_anova_table(res.aov)## ANOVA Table (type III tests)
##
## Effect DFn DFd F p p<.05 ges
## 1 group 1 101 1.051 3.08e-01 0.007
## 2 piece 2 202 14.965 8.70e-07 * 0.040
## 3 group:piece 2 202 0.709 4.93e-01 0.002# PWC: Piece
## Pairwise comparisons between piece levels:
### Beethoven > Folk, Schnittke
pwc <- data %>%
#group_by(group) %>% # don't need to group by group because there was no interaction and the main effect of piece should be examined on all of the data
pairwise_t_test(Mindwandering ~ piece, p.adjust.method = "bonferroni")
pwc## # A tibble: 3 × 9
## .y. group1 group2 n1 n2 p p.signif p.adj p.adj.signif
## * <chr> <chr> <chr> <int> <int> <dbl> <chr> <dbl> <chr>
## 1 Mindwandering Beetho… Schni… 123 119 5.9 e-4 *** 1.77e-3 **
## 2 Mindwandering Beetho… Folk 123 117 4.53e-7 **** 1.36e-6 ****
## 3 Mindwandering Schnit… Folk 119 117 9.49e-2 ns 2.85e-1 ns# Mean +/-SD
data%>%group_by(piece)%>%summarise(mean = mean(Mindwandering), SD = sd(Mindwandering))## # A tibble: 3 × 3
## piece mean SD
## <fct> <dbl> <dbl>
## 1 Beethoven 0.336 0.999
## 2 Schnittke -0.0943 0.973
## 3 Folk -0.305 0.922Test without extreme outliers
Repeat test and pwc without extreme outliers
In this case, the virtual group reported more mind-wandering in Beethoven as compared to Folk as well
# Same test without extreme outliers = same result
res.aov <- anova_test(
data = data_u_extreme, dv = Mindwandering, wid = Pt_ID,
between = group, within = piece
)
get_anova_table(res.aov)## ANOVA Table (type III tests)
##
## Effect DFn DFd F p p<.05 ges
## 1 group 1 98 0.009 9.25e-01 6.38e-05
## 2 piece 2 196 11.041 2.86e-05 * 3.20e-02
## 3 group:piece 2 196 1.097 3.36e-01 3.00e-03### REPEAT WITH DATA UTEN EXTREME ###
# PWC: Group
## Pairwise comparisons between group levels: None significant
pwc <- data_u_extreme %>%
group_by(piece) %>%
pairwise_t_test(Mindwandering ~ group, p.adjust.method = "bonferroni")
pwc## # A tibble: 3 × 10
## piece .y. group1 group2 n1 n2 p p.signif p.adj p.adj.signif
## * <fct> <chr> <chr> <chr> <int> <int> <dbl> <chr> <dbl> <chr>
## 1 Beethoven Mindw… Live Virtu… 87 32 0.581 ns 0.581 ns
## 2 Schnittke Mindw… Live Virtu… 90 25 0.122 ns 0.122 ns
## 3 Folk Mindw… Live Virtu… 88 24 0.0632 ns 0.0632 ns# PWC: Piece
## Pairwise comparisons between piece levels:
### Beethoven > Folk, Schnittke
pwc <- data_u_extreme %>%
group_by(group) %>%
pairwise_t_test(Mindwandering ~ piece, p.adjust.method = "bonferroni")
pwc## # A tibble: 6 × 10
## group .y. group1 group2 n1 n2 p p.signif p.adj p.adj.signif
## * <fct> <chr> <chr> <chr> <int> <int> <dbl> <chr> <dbl> <chr>
## 1 Live Mindw… Beeth… Schni… 87 90 8.1 e-4 *** 2.43e-3 **
## 2 Live Mindw… Beeth… Folk 87 88 1.29e-6 **** 3.87e-6 ****
## 3 Live Mindw… Schni… Folk 90 88 1.11e-1 ns 3.32e-1 ns
## 4 Virtual Mindw… Beeth… Schni… 32 25 2.32e-1 ns 6.96e-1 ns
## 5 Virtual Mindw… Beeth… Folk 32 24 4.12e-2 * 1.24e-1 ns
## 6 Virtual Mindw… Schni… Folk 25 24 4.06e-1 ns 1 e+0 nsVisualize
colours_DSQ<-c("#2d769a","#b34036")
#update group label
data$group<-factor(data$group, levels = c("Live", "Virtual"), labels = c("Live", "Livestreaming"))
# BOXPLOT
data%>%ggplot(aes(x = group, y = Mindwandering, fill = group))+
geom_boxplot()+
facet_grid(cols = vars(piece))+
labs(title = "Effect of Piece and Group on Mind-wandering",y = "MW Score", x = "")+
scale_fill_manual(values= colours_DSQ, name = "Concert Group")+
theme_DSQ()+
theme(legend.position='None')## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database## Warning in grid.Call.graphics(C_text, as.graphicsAnnot(x$label), x$x, x$y, :
## font family not found in Windows font database## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
graphname<-paste0("../plots/Mind-wandering-by-piece-Group.png")
ggsave(graphname, width = 15, height = 10, units = 'cm', dpi = 500)
## DOTPLOT
dot<-ggdotplot(data, x = "piece", y = "Mindwandering", fill = "group", facet.by = "group", add = "mean_sd")+
labs(title = "Effect of Piece on Mind-wandering",y = "Mind-wandering Score", x = "")+
scale_fill_manual(values = colours_DSQ, name = "Concert Group")+
theme_DSQ()+
theme(legend.position='None')
dot## Bin width defaults to 1/30 of the range of the data. Pick better value with `binwidth`.## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database## Warning in grid.Call.graphics(C_text, as.graphicsAnnot(x$label), x$x, x$y, :
## font family not found in Windows font database## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
pwc<-pwc%>%add_xy_position(x = "piece", step.increase = .3)
pwc$y.position<-pwc$y.position+.3
pwc$xmax[pwc$xmax==4]<-3 # because not comparing bach and folk is 3 in this case, not 4
# add significance value to plot
dot+stat_pvalue_manual(pwc, hide.ns = TRUE)#, label = "p.adj.signif")## Bin width defaults to 1/30 of the range of the data. Pick better value with `binwidth`.## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database## Warning in grid.Call.graphics(C_text, as.graphicsAnnot(x$label), x$x, x$y, :
## font family not found in Windows font database## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
graphname<-paste0("../plots/Mindwandering-by-piece-Group_dot.png")
ggsave(graphname,
width = 17,
height = 10,
units = 'cm',
dpi = 500)## Bin width defaults to 1/30 of the range of the data. Pick better value with `binwidth`.## Because there was only a main effect of piece and not an interaction, I need to plot to show the piece differences only.
dot<-ggdotplot(data, x = "piece", y = "Mindwandering", fill = "group", add = "mean_sd")+
labs(title = "Effect of Piece on Mind-wandering",y = "Mind-wandering Score", x = "")+
scale_fill_manual(values = colours_DSQ, name = "Concert Group")+
theme_DSQ()+
geom_signif(comparisons = list(c("Beethoven", "Schnittke"),c("Beethoven", "Folk"), c("Schnittke", "Folk")), annotations = c("***", "***", "**"), y_position = c(2.7, 3, 2.7), vjust = .5)
#theme(legend.position='None')
dot## Bin width defaults to 1/30 of the range of the data. Pick better value with `binwidth`.## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database## Warning in grid.Call.graphics(C_text, as.graphicsAnnot(x$label), x$x, x$y, :
## font family not found in Windows font database## Warning in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y, : font
## family not found in Windows font database
graphname<-paste0("../plots/Mindwandering-by-piece_dot.png")
ggsave(graphname,
width = 17,
height = 10,
units = 'cm',
dpi = 500)## Bin width defaults to 1/30 of the range of the data. Pick better value with `binwidth`.3.6 Absorption & motion (and piece and group)
What is the relation between absorption and motion?
Useful tutorial about lme and fixed and random effects provided by Jonna: https://psyteachr.github.io/stat-models-v1/linear-mixed-effects-models-with-one-random-factor.html
3.6.1 LME with Quantity of Motion (QoM) & Absorption
dat<-df.full%>%select(Pt_ID, group,contains("Absorption"), contains("QoM"))
df.long<-dat%>%pivot_longer(!c(group, Pt_ID), #make long
names_to = c("var", "piece"),
names_pattern ="(.*)_(.*)",
values_to = "response")
# remove Bach
df.long<-df.long%>%filter(! piece == "Bach")
df.wide<-df.long%>%pivot_wider(names_from = var, values_from = response)
df.wide$piece<-factor(df.wide$piece, levels = c("Beethoven", "Schnittke", "Folk"))
#factor for the correct facet order
# note df.wide is the same as data including NA
data<-df.wide%>%drop_na() #408 to 287Remove extreme outliers
Absorption
outliers<-data %>%
group_by(group, piece) %>%
identify_outliers(Absorption)
outliers # 3; None are extreme.## # A tibble: 3 × 7
## group piece Pt_ID Absorption mQoM is.outlier is.extreme
## <fct> <fct> <chr> <dbl> <dbl> <lgl> <lgl>
## 1 Live Schnittke ADQ003 -2.79 0.0924 TRUE FALSE
## 2 Virtual Beethoven BEQ096 1.17 0.119 TRUE FALSE
## 3 Virtual Beethoven BDQ092 -2.61 0.460 TRUE FALSEextreme<-outliers%>%filter(is.extreme == TRUE)
extreme # none are extreme## # A tibble: 0 × 7
## # … with 7 variables: group <fct>, piece <fct>, Pt_ID <chr>, Absorption <dbl>,
## # mQoM <dbl>, is.outlier <lgl>, is.extreme <lgl># remove specific instances that are outliers (Pt_ID and piece, because lme can handle missing data so you don't need to remove the whole participant)
# data uten outliers
data_u_outliers<-data%>% # 287 to 284 : looks good!
group_by(group, piece) %>%
filter(!is_outlier(Absorption))%>%
ungroup()
# data uten extreme
data_u_extreme<-data%>% # 287 to 287 : looks good!
group_by(group, piece) %>%
filter(!is_extreme(Absorption))%>%
ungroup()QoM
outliers<-data %>%
group_by(group, piece) %>%
identify_outliers(mQoM)
outliers # 21 ## # A tibble: 21 × 7
## group piece Pt_ID Absorption mQoM is.outlier is.extreme
## <fct> <fct> <chr> <dbl> <dbl> <lgl> <lgl>
## 1 Live Beethoven ADQ010 0.00492 0.133 TRUE FALSE
## 2 Live Beethoven ADQ025 0.0338 0.148 TRUE FALSE
## 3 Live Beethoven ADQ049 1.08 0.144 TRUE FALSE
## 4 Live Beethoven ADQ016 1.54 0.166 TRUE FALSE
## 5 Live Schnittke ADQ049 1.03 0.170 TRUE FALSE
## 6 Live Schnittke ADQ063 -0.627 0.168 TRUE FALSE
## 7 Live Schnittke ADQ066 -0.856 0.177 TRUE FALSE
## 8 Live Schnittke ADQ016 1.43 0.169 TRUE FALSE
## 9 Live Folk AEQ085 -1.94 0.427 TRUE TRUE
## 10 Live Folk ADQ018 -0.169 0.307 TRUE TRUE
## # … with 11 more rowsextreme_outliers<- outliers%>%filter(is.extreme == TRUE)
extreme_outliers # 6 instances## # A tibble: 6 × 7
## group piece Pt_ID Absorption mQoM is.outlier is.extreme
## <fct> <fct> <chr> <dbl> <dbl> <lgl> <lgl>
## 1 Live Folk AEQ085 -1.94 0.427 TRUE TRUE
## 2 Live Folk ADQ018 -0.169 0.307 TRUE TRUE
## 3 Virtual Beethoven BEQ103 -0.263 0.570 TRUE TRUE
## 4 Virtual Beethoven BDQ092 -2.61 0.460 TRUE TRUE
## 5 Virtual Schnittke BEQ114 -0.620 0.325 TRUE TRUE
## 6 Virtual Folk BEQ106 -0.260 0.486 TRUE TRUEdata_u_outliers<-data_u_outliers%>% # 284 to 264
group_by(group, piece) %>%
filter(!is_outlier(mQoM))%>%
ungroup()
data_u_extreme<-data_u_extreme%>% # 287 to 281 : looks good!
group_by(group, piece) %>%
filter(!is_extreme(mQoM))%>%
ungroup()Test
This model should be built to only show the additional contribution of mQoM and its interactions with piece and group, with a random intercept and slope of participant.
There was a significant main effect of piece, χ2(2) = 10.73, p = 0.0047, a significant main effect of group, χ2(1) = 4.96, p = 0.026, however no significant main effect of quantity of motion, χ2(1) = .33, p = 0.57. Importantly, there was a significant interaction between motion and group, χ2(2) = 10.49, p = 0.0012, however there was no significant interaction of piece with motion, χ2(2) = 2,84, p = 0.24. The three-way interaction between motion, group, and piece was not significant either, χ2(2) = .51, p = 0.76.
Using data_u_extreme returns a warning
baseline<-lmer(Absorption ~ 1 +(1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE) ## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, :
## unable to evaluate scaled gradient## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, :
## Model failed to converge: degenerate Hessian with 1 negative eigenvalues# "Warning: unable to evaluate scaled gradientWarning: Model failed to converge: degenerate Hessian with 1 negative eigenvaluesWarning: Model failed to converge with 1 negative eigenvalue: -5.9e-04"Individual effects of group, piece, mQoM
What are the individual effects of group, piece, mQoM? The same warning is not returned when using all data therefore consider using all data. ##### All data data = data
baseline<-lmer(Absorption ~ 1 +(1+mQoM|Pt_ID), data = data, REML = FALSE)
groupM<-lmer(Absorption ~ 1 + group + (1+mQoM|Pt_ID), data = data, REML = FALSE) #boundary (singular) fit: see help('isSingular')## boundary (singular) fit: see help('isSingular')# no singular warning when using data uten extreme
anova(baseline, groupM) # Significant## Data: data
## Models:
## baseline: Absorption ~ 1 + (1 + mQoM | Pt_ID)
## groupM: Absorption ~ 1 + group + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 773.85 792.15 -381.93 763.85
## groupM 6 770.89 792.84 -379.44 758.89 4.9657 1 0.02585 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1# different than the mixed ANOVA
pieceM<-lmer(Absorption ~ 1 + piece + (1+mQoM|Pt_ID), data = data, REML = FALSE) # No singular warning with data but there is one with data without extreme
anova(baseline, pieceM) # sig## Data: data
## Models:
## baseline: Absorption ~ 1 + (1 + mQoM | Pt_ID)
## pieceM: Absorption ~ 1 + piece + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 773.85 792.15 -381.93 763.85
## pieceM 7 766.31 791.92 -376.15 752.31 11.543 2 0.003115 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1summary(pieceM) # folk had greater absorption than beethoven and schnittke## Linear mixed model fit by maximum likelihood ['lmerMod']
## Formula: Absorption ~ 1 + piece + (1 + mQoM | Pt_ID)
## Data: data
##
## AIC BIC logLik deviance df.resid
## 766.3 791.9 -376.2 752.3 280
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.00126 -0.52787 0.07348 0.63274 1.72454
##
## Random effects:
## Groups Name Variance Std.Dev. Corr
## Pt_ID (Intercept) 0.1886 0.4343
## mQoM 3.1258 1.7680 1.00
## Residual 0.5330 0.7301
## Number of obs: 287, groups: Pt_ID, 110
##
## Fixed effects:
## Estimate Std. Error t value
## (Intercept) -0.14332 0.09311 -1.539
## pieceSchnittke 0.04851 0.10659 0.455
## pieceFolk 0.34756 0.10751 3.233
##
## Correlation of Fixed Effects:
## (Intr) pcSchn
## piecSchnttk -0.533
## pieceFolk -0.505 0.472qomM<-lmer(Absorption ~ 1 + mQoM + (1+mQoM|Pt_ID), data = data, REML = FALSE) #boundary (singular) fit: see help('isSingular')## boundary (singular) fit: see help('isSingular')# no singular warning when using data uten extreme
anova(baseline, qomM) # NS## Data: data
## Models:
## baseline: Absorption ~ 1 + (1 + mQoM | Pt_ID)
## qomM: Absorption ~ 1 + mQoM + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 773.85 792.15 -381.93 763.85
## qomM 6 775.41 797.37 -381.71 763.41 0.4399 1 0.5072Without extreme outliers
data = data uten extreme
# Individual effects of group, piece, mQoM
baseline<-lmer(Absorption ~ 1 +(1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE) # warning: model failed to converge## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, :
## unable to evaluate scaled gradient## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, :
## Model failed to converge: degenerate Hessian with 1 negative eigenvaluesgroupM<-lmer(Absorption ~ 1 + group + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(baseline, groupM) # Significant## Data: data_u_extreme
## Models:
## baseline: Absorption ~ 1 + (1 + mQoM | Pt_ID)
## groupM: Absorption ~ 1 + group + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 758.25 776.44 -374.12 748.25
## groupM 6 756.29 778.12 -372.15 744.29 3.9583 1 0.04664 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1qomM<-lmer(Absorption ~ 1 + mQoM + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(baseline, qomM) # NS## Data: data_u_extreme
## Models:
## baseline: Absorption ~ 1 + (1 + mQoM | Pt_ID)
## qomM: Absorption ~ 1 + mQoM + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 758.25 776.44 -374.12 748.25
## qomM 6 760.01 781.84 -374.01 748.01 0.2359 1 0.6272# different than the mixed ANOVA
pieceM<-lmer(Absorption ~ 1 + piece + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE)## boundary (singular) fit: see help('isSingular')anova(baseline, pieceM) # sig## Data: data_u_extreme
## Models:
## baseline: Absorption ~ 1 + (1 + mQoM | Pt_ID)
## pieceM: Absorption ~ 1 + piece + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 758.25 776.44 -374.12 748.25
## pieceM 7 751.52 776.99 -368.76 737.52 10.729 2 0.004681 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1summary(pieceM)## Linear mixed model fit by maximum likelihood ['lmerMod']
## Formula: Absorption ~ 1 + piece + (1 + mQoM | Pt_ID)
## Data: data_u_extreme
##
## AIC BIC logLik deviance df.resid
## 751.5 777.0 -368.8 737.5 274
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -2.96178 -0.51313 0.08891 0.64638 1.71835
##
## Random effects:
## Groups Name Variance Std.Dev. Corr
## Pt_ID (Intercept) 0.1427 0.3777
## mQoM 5.0546 2.2482 1.00
## Residual 0.5424 0.7365
## Number of obs: 281, groups: Pt_ID, 110
##
## Fixed effects:
## Estimate Std. Error t value
## (Intercept) -0.13799 0.09330 -1.479
## pieceSchnittke 0.04338 0.10855 0.400
## pieceFolk 0.34640 0.11035 3.139
##
## Correlation of Fixed Effects:
## (Intr) pcSchn
## piecSchnttk -0.541
## pieceFolk -0.510 0.470
## optimizer (nloptwrap) convergence code: 0 (OK)
## boundary (singular) fit: see help('isSingular')Model fitting
# Baseline model
baseline<-lmer(Absorption ~ 1 + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE) # unable to converge## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, :
## unable to evaluate scaled gradient## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, :
## Model failed to converge: degenerate Hessian with 1 negative eigenvaluespieceM<-lmer(Absorption ~ 1 + piece + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE) # boundary warning SIG## boundary (singular) fit: see help('isSingular')anova(baseline, pieceM)## Data: data_u_extreme
## Models:
## baseline: Absorption ~ 1 + (1 + mQoM | Pt_ID)
## pieceM: Absorption ~ 1 + piece + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 758.25 776.44 -374.12 748.25
## pieceM 7 751.52 776.99 -368.76 737.52 10.729 2 0.004681 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1## no random slope comparison. - it is less sig with the random slope of qom
baseline<-lmer(Absorption ~ 1 + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
pieceM<-lmer(Absorption ~ 1 + piece + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(baseline, pieceM)## Data: data_u_extreme
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## pieceM: Absorption ~ 1 + piece + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 759.03 769.95 -376.52 753.03
## pieceM 5 750.12 768.32 -370.06 740.12 12.906 2 0.001576 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1## comparison with full dataset
baseline<-lmer(Absorption ~ 1 + (1+mQoM|Pt_ID), data = data, REML = FALSE)
pieceM<-lmer(Absorption ~ 1 + piece + (1+mQoM|Pt_ID), data = data, REML = FALSE)
anova(baseline, pieceM)## Data: data
## Models:
## baseline: Absorption ~ 1 + (1 + mQoM | Pt_ID)
## pieceM: Absorption ~ 1 + piece + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 773.85 792.15 -381.93 763.85
## pieceM 7 766.31 791.92 -376.15 752.31 11.543 2 0.003115 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1data%>%group_by(piece)%>%summarize(n())## # A tibble: 3 × 2
## piece `n()`
## <fct> <int>
## 1 Beethoven 103
## 2 Schnittke 92
## 3 Folk 92# effect of group
pieceM<-lmer(Absorption ~ 1 + piece + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE) # boundary warning## boundary (singular) fit: see help('isSingular')piece_group<-lmer(Absorption ~ 1 + group + piece + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(pieceM, piece_group) # sig effect of group## Data: data_u_extreme
## Models:
## pieceM: Absorption ~ 1 + piece + (1 + mQoM | Pt_ID)
## piece_group: Absorption ~ 1 + group + piece + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## pieceM 7 751.52 776.99 -368.76 737.52
## piece_group 8 748.56 777.67 -366.28 732.56 4.9623 1 0.0259 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1## no random slope comparison - more sig without random slope
pieceM<-lmer(Absorption ~ 1 + piece + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
piece_group<-lmer(Absorption ~ 1 + group + piece + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(pieceM, piece_group) # p = .006; more sig effect of group without random slope (p = .02)## Data: data_u_extreme
## Models:
## pieceM: Absorption ~ 1 + piece + (1 | Pt_ID)
## piece_group: Absorption ~ 1 + group + piece + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## pieceM 5 750.12 768.32 -370.06 740.12
## piece_group 6 744.80 766.63 -366.40 732.80 7.326 1 0.006796 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1# interaction group and piece: NS
piece_group<-lmer(Absorption ~ 1 + group + piece + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE)
pieceXgroup<-lmer(Absorption ~ 1 + group*piece + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE) # boundary warning## boundary (singular) fit: see help('isSingular')anova(piece_group, pieceXgroup) # NS- the interaction does not add more than the main effects## Data: data_u_extreme
## Models:
## piece_group: Absorption ~ 1 + group + piece + (1 + mQoM | Pt_ID)
## pieceXgroup: Absorption ~ 1 + group * piece + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## piece_group 8 748.56 777.67 -366.28 732.56
## pieceXgroup 10 751.46 787.85 -365.73 731.46 1.0966 2 0.5779# effect of motion
piece_group<-lmer(Absorption ~ 1 + group + piece + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE)
group_piece_qomM<-lmer(Absorption ~ 1 + group + piece + mQoM + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(piece_group, group_piece_qomM) # NS - adding QoM NS. what about interactions?## Data: data_u_extreme
## Models:
## piece_group: Absorption ~ 1 + group + piece + (1 + mQoM | Pt_ID)
## group_piece_qomM: Absorption ~ 1 + group + piece + mQoM + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## piece_group 8 748.56 777.67 -366.28 732.56
## group_piece_qomM 9 750.23 782.98 -366.12 732.23 0.328 1 0.5668# interaction piece and motion
group_piece_x_qomM<-lmer(Absorption ~ 1 + group + piece*mQoM + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(group_piece_qomM, group_piece_x_qomM) # NS - adding QoM x piece interaction NS. ## Data: data_u_extreme
## Models:
## group_piece_qomM: Absorption ~ 1 + group + piece + mQoM + (1 + mQoM | Pt_ID)
## group_piece_x_qomM: Absorption ~ 1 + group + piece * mQoM + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## group_piece_qomM 9 750.23 782.98 -366.12 732.23
## group_piece_x_qomM 11 751.40 791.42 -364.70 729.40 2.8352 2 0.2423# BEST MODEL: main effect piece and interaction between group and motion
piece_group_x_qomM<-lmer(Absorption ~ 1 + piece + group*mQoM + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE) # boundary warning## boundary (singular) fit: see help('isSingular')anova(group_piece_qomM, piece_group_x_qomM) # Significant: there is added benefit of adding the interaction with qom and group. ## Data: data_u_extreme
## Models:
## group_piece_qomM: Absorption ~ 1 + group + piece + mQoM + (1 + mQoM | Pt_ID)
## piece_group_x_qomM: Absorption ~ 1 + piece + group * mQoM + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## group_piece_qomM 9 750.23 782.98 -366.12 732.23
## piece_group_x_qomM 10 741.74 778.12 -360.87 721.74 10.491 1 0.0012 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1# other models
piece_x_group_group_x_qomM<-lmer(Absorption ~ 1 + piece*group + group*mQoM + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE)## boundary (singular) fit: see help('isSingular')anova(piece_group_x_qomM, piece_x_group_group_x_qomM) # ns - no benefit of adding interaction of piece and group## Data: data_u_extreme
## Models:
## piece_group_x_qomM: Absorption ~ 1 + piece + group * mQoM + (1 + mQoM | Pt_ID)
## piece_x_group_group_x_qomM: Absorption ~ 1 + piece * group + group * mQoM + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df
## piece_group_x_qomM 10 741.74 778.12 -360.87 721.74
## piece_x_group_group_x_qomM 12 743.50 787.16 -359.75 719.50 2.239 2
## Pr(>Chisq)
## piece_group_x_qomM
## piece_x_group_group_x_qomM 0.3264# no sig 3-way
qomM_x_piece_x_group<-lmer(Absorption ~ 1 + mQoM*group*piece + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE) ## boundary (singular) fit: see help('isSingular')anova(piece_group_x_qomM, qomM_x_piece_x_group) # NS - no 3-way interaction## Data: data_u_extreme
## Models:
## piece_group_x_qomM: Absorption ~ 1 + piece + group * mQoM + (1 + mQoM | Pt_ID)
## qomM_x_piece_x_group: Absorption ~ 1 + mQoM * group * piece + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## piece_group_x_qomM 10 741.74 778.12 -360.87 721.74
## qomM_x_piece_x_group 16 750.08 808.29 -359.04 718.08 3.6643 6 0.722#refit with data_u_extreme for these comparisons:
baseline<-lmer(Absorption ~ 1 + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE) # unable to converge## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, :
## unable to evaluate scaled gradient
## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, :
## Model failed to converge: degenerate Hessian with 1 negative eigenvaluespieceM<-lmer(Absorption ~ 1 + piece + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE) # boundary warning SIG## boundary (singular) fit: see help('isSingular')anova(baseline, pieceM,piece_group,group_piece_qomM, piece_group_x_qomM) # sig## Data: data_u_extreme
## Models:
## baseline: Absorption ~ 1 + (1 + mQoM | Pt_ID)
## pieceM: Absorption ~ 1 + piece + (1 + mQoM | Pt_ID)
## piece_group: Absorption ~ 1 + group + piece + (1 + mQoM | Pt_ID)
## group_piece_qomM: Absorption ~ 1 + group + piece + mQoM + (1 + mQoM | Pt_ID)
## piece_group_x_qomM: Absorption ~ 1 + piece + group * mQoM + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 758.25 776.44 -374.12 748.25
## pieceM 7 751.52 776.99 -368.76 737.52 10.7285 2 0.004681 **
## piece_group 8 748.56 777.67 -366.28 732.56 4.9623 1 0.025905 *
## group_piece_qomM 9 750.23 782.98 -366.12 732.23 0.3280 1 0.566845
## piece_group_x_qomM 10 741.74 778.12 -360.87 721.74 10.4908 1 0.001200 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1anova(baseline, pieceM,piece_group,piece_group_x_qomM) # sig even if comparing just with the main effects of piece and group.## Data: data_u_extreme
## Models:
## baseline: Absorption ~ 1 + (1 + mQoM | Pt_ID)
## pieceM: Absorption ~ 1 + piece + (1 + mQoM | Pt_ID)
## piece_group: Absorption ~ 1 + group + piece + (1 + mQoM | Pt_ID)
## piece_group_x_qomM: Absorption ~ 1 + piece + group * mQoM + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 758.25 776.44 -374.12 748.25
## pieceM 7 751.52 776.99 -368.76 737.52 10.7285 2 0.004681 **
## piece_group 8 748.56 777.67 -366.28 732.56 4.9623 1 0.025905 *
## piece_group_x_qomM 10 741.74 778.12 -360.87 721.74 10.8188 2 0.004474 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1# no sig interaction of piece with motion
piece_x_qom_group_x_qomM<-lmer(Absorption ~ 1 + piece*mQoM + group*mQoM + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE) # boundary warning## boundary (singular) fit: see help('isSingular')# no sig interction of piece with group
piece_x_qom_group_x_qomM_group_x_piece<-lmer(Absorption ~ 1 + piece*group + piece*mQoM + group*mQoM + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE) # boundary warning## boundary (singular) fit: see help('isSingular')# no sig 3-way
qomM_x_piece_x_group<-lmer(Absorption ~ 1 + mQoM*group*piece + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE) # boundary warning## boundary (singular) fit: see help('isSingular')anova(baseline, pieceM,piece_group,group_piece_qomM, piece_group_x_qomM, piece_x_qom_group_x_qomM, piece_x_qom_group_x_qomM_group_x_piece, qomM_x_piece_x_group) ## Data: data_u_extreme
## Models:
## baseline: Absorption ~ 1 + (1 + mQoM | Pt_ID)
## pieceM: Absorption ~ 1 + piece + (1 + mQoM | Pt_ID)
## piece_group: Absorption ~ 1 + group + piece + (1 + mQoM | Pt_ID)
## group_piece_qomM: Absorption ~ 1 + group + piece + mQoM + (1 + mQoM | Pt_ID)
## piece_group_x_qomM: Absorption ~ 1 + piece + group * mQoM + (1 + mQoM | Pt_ID)
## piece_x_qom_group_x_qomM: Absorption ~ 1 + piece * mQoM + group * mQoM + (1 + mQoM | Pt_ID)
## piece_x_qom_group_x_qomM_group_x_piece: Absorption ~ 1 + piece * group + piece * mQoM + group * mQoM + (1 + mQoM | Pt_ID)
## qomM_x_piece_x_group: Absorption ~ 1 + mQoM * group * piece + (1 + mQoM | Pt_ID)
## npar AIC BIC logLik deviance
## baseline 5 758.25 776.44 -374.12 748.25
## pieceM 7 751.52 776.99 -368.76 737.52
## piece_group 8 748.56 777.67 -366.28 732.56
## group_piece_qomM 9 750.23 782.98 -366.12 732.23
## piece_group_x_qomM 10 741.74 778.12 -360.87 721.74
## piece_x_qom_group_x_qomM 12 744.07 787.73 -360.04 720.07
## piece_x_qom_group_x_qomM_group_x_piece 14 746.58 797.52 -359.29 718.58
## qomM_x_piece_x_group 16 750.08 808.29 -359.04 718.08
## Chisq Df Pr(>Chisq)
## baseline
## pieceM 10.7285 2 0.004681 **
## piece_group 4.9623 1 0.025905 *
## group_piece_qomM 0.3280 1 0.566845
## piece_group_x_qomM 10.4908 1 0.001200 **
## piece_x_qom_group_x_qomM 1.6678 2 0.434344
## piece_x_qom_group_x_qomM_group_x_piece 1.4871 2 0.475430
## qomM_x_piece_x_group 0.5094 2 0.775146
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1plot(piece_group_x_qomM)
summary(piece_group_x_qomM)## Linear mixed model fit by maximum likelihood ['lmerMod']
## Formula: Absorption ~ 1 + piece + group * mQoM + (1 + mQoM | Pt_ID)
## Data: data_u_extreme
##
## AIC BIC logLik deviance df.resid
## 741.7 778.1 -360.9 721.7 271
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.2501 -0.5201 0.1077 0.6635 1.7546
##
## Random effects:
## Groups Name Variance Std.Dev. Corr
## Pt_ID (Intercept) 0.4668 0.6832
## mQoM 0.8365 0.9146 -1.00
## Residual 0.5242 0.7241
## Number of obs: 281, groups: Pt_ID, 110
##
## Fixed effects:
## Estimate Std. Error t value
## (Intercept) -0.4209621 0.2112066 -1.993
## pieceSchnittke -0.0009692 0.1069168 -0.009
## pieceFolk 0.2453887 0.1222478 2.007
## groupVirtual 0.6728345 0.3909478 1.721
## mQoM 4.1916065 2.0224924 2.072
## groupVirtual:mQoM -9.6236873 2.7904788 -3.449
##
## Correlation of Fixed Effects:
## (Intr) pcSchn picFlk grpVrt mQoM
## piecSchnttk -0.169
## pieceFolk 0.191 0.455
## groupVirtul -0.540 -0.044 -0.233
## mQoM -0.878 -0.087 -0.471 0.523
## grpVrtl:mQM 0.631 0.088 0.350 -0.879 -0.725
## optimizer (nloptwrap) convergence code: 0 (OK)
## boundary (singular) fit: see help('isSingular')Refit with REML to report those variance estimates
From: https://gkhajduk.github.io/2017-03-09-mixed-models/
“Notice that we have fitted our models with REML = FALSE.
REML stands for restricted (or “residual”) maximum likelihood and it is the default parameter estimation criterion for linear mixed models. As you probably guessed, ML stands for maximum likelihood - you can set REML = FALSE in your call to lmer to use ML estimates. However, ML estimates are known to be bias and with REML being usually less bias, REML estimates of variance components are generally preferred. This is why in our previous models we skipped setting REML - we just left it as default (i.e. REML = TRUE).
REML assumes that fixed effects structure is correct. You should use maximum likelihood when comparing models with different fixed effects, as ML doesn’t rely on the coefficients of the fixed effects - and that’s why we are refitting our full and reduced models above with the addition of REML = FALSE in the call.
Even though you use ML to compare models you should report parameter estimates from your final “best” REML model, as ML may underestimate variance of the random effects.”
Refitting with REML produces the same results.
piece_group_x_qomM<-lmer(Absorption ~ 1 + piece + group*mQoM + (1+mQoM|Pt_ID), data = data_u_extreme, REML = FALSE) ## boundary (singular) fit: see help('isSingular')summary(piece_group_x_qomM)## Linear mixed model fit by maximum likelihood ['lmerMod']
## Formula: Absorption ~ 1 + piece + group * mQoM + (1 + mQoM | Pt_ID)
## Data: data_u_extreme
##
## AIC BIC logLik deviance df.resid
## 741.7 778.1 -360.9 721.7 271
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.2501 -0.5201 0.1077 0.6635 1.7546
##
## Random effects:
## Groups Name Variance Std.Dev. Corr
## Pt_ID (Intercept) 0.4668 0.6832
## mQoM 0.8365 0.9146 -1.00
## Residual 0.5242 0.7241
## Number of obs: 281, groups: Pt_ID, 110
##
## Fixed effects:
## Estimate Std. Error t value
## (Intercept) -0.4209621 0.2112066 -1.993
## pieceSchnittke -0.0009692 0.1069168 -0.009
## pieceFolk 0.2453887 0.1222478 2.007
## groupVirtual 0.6728345 0.3909478 1.721
## mQoM 4.1916065 2.0224924 2.072
## groupVirtual:mQoM -9.6236873 2.7904788 -3.449
##
## Correlation of Fixed Effects:
## (Intr) pcSchn picFlk grpVrt mQoM
## piecSchnttk -0.169
## pieceFolk 0.191 0.455
## groupVirtul -0.540 -0.044 -0.233
## mQoM -0.878 -0.087 -0.471 0.523
## grpVrtl:mQM 0.631 0.088 0.350 -0.879 -0.725
## optimizer (nloptwrap) convergence code: 0 (OK)
## boundary (singular) fit: see help('isSingular')## Refit with REML
piece_group_x_qomM<-lmer(Absorption ~ 1 + piece + group*mQoM + (1+mQoM|Pt_ID), data = data_u_extreme, REML = TRUE) ## boundary (singular) fit: see help('isSingular')summary(piece_group_x_qomM)## Linear mixed model fit by REML ['lmerMod']
## Formula: Absorption ~ 1 + piece + group * mQoM + (1 + mQoM | Pt_ID)
## Data: data_u_extreme
##
## REML criterion at convergence: 725.9
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.2058 -0.5031 0.1097 0.6554 1.7329
##
## Random effects:
## Groups Name Variance Std.Dev. Corr
## Pt_ID (Intercept) 0.4457 0.6676
## mQoM 0.4759 0.6899 -1.00
## Residual 0.5346 0.7311
## Number of obs: 281, groups: Pt_ID, 110
##
## Fixed effects:
## Estimate Std. Error t value
## (Intercept) -0.4140551 0.2134536 -1.940
## pieceSchnittke 0.0003389 0.1079926 0.003
## pieceFolk 0.2464637 0.1236061 1.994
## groupVirtual 0.6685884 0.3959666 1.688
## mQoM 4.1132637 2.0574843 1.999
## groupVirtual:mQoM -9.5634321 2.8473279 -3.359
##
## Correlation of Fixed Effects:
## (Intr) pcSchn picFlk grpVrt mQoM
## piecSchnttk -0.169
## pieceFolk 0.196 0.454
## groupVirtul -0.539 -0.044 -0.234
## mQoM -0.878 -0.087 -0.473 0.522
## grpVrtl:mQM 0.629 0.088 0.349 -0.878 -0.723
## optimizer (nloptwrap) convergence code: 0 (OK)
## boundary (singular) fit: see help('isSingular')## fitting with data or df.wide (contains lots of NAs) produce the same results.
piece_group_x_qomM<-lmer(Absorption ~ 1 + piece + group*mQoM + (1+mQoM|Pt_ID), data = data, REML = FALSE)## boundary (singular) fit: see help('isSingular')summary(piece_group_x_qomM)## Linear mixed model fit by maximum likelihood ['lmerMod']
## Formula: Absorption ~ 1 + piece + group * mQoM + (1 + mQoM | Pt_ID)
## Data: data
##
## AIC BIC logLik deviance df.resid
## 765.1 801.7 -372.5 745.1 277
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.0683 -0.4836 0.1043 0.6406 1.6873
##
## Random effects:
## Groups Name Variance Std.Dev. Corr
## Pt_ID (Intercept) 0.2243 0.4736
## mQoM 1.3255 1.1513 1.00
## Residual 0.5327 0.7299
## Number of obs: 287, groups: Pt_ID, 110
##
## Fixed effects:
## Estimate Std. Error t value
## (Intercept) -0.15468 0.17801 -0.869
## pieceSchnittke 0.02719 0.10693 0.254
## pieceFolk 0.30661 0.12007 2.554
## groupVirtual -0.06614 0.31748 -0.208
## mQoM 1.14869 1.70581 0.673
## groupVirtual:mQoM -3.05457 2.23831 -1.365
##
## Correlation of Fixed Effects:
## (Intr) pcSchn picFlk grpVrt mQoM
## piecSchnttk -0.235
## pieceFolk 0.125 0.450
## groupVirtul -0.543 -0.037 -0.222
## mQoM -0.829 -0.065 -0.450 0.515
## grpVrtl:mQM 0.621 0.083 0.350 -0.803 -0.760
## optimizer (nloptwrap) convergence code: 0 (OK)
## boundary (singular) fit: see help('isSingular')piece_group_x_qomM<-lmer(Absorption ~ 1 + piece + group*mQoM + (1+mQoM|Pt_ID), data = df.wide, REML = FALSE)## boundary (singular) fit: see help('isSingular')summary(piece_group_x_qomM)## Linear mixed model fit by maximum likelihood ['lmerMod']
## Formula: Absorption ~ 1 + piece + group * mQoM + (1 + mQoM | Pt_ID)
## Data: df.wide
##
## AIC BIC logLik deviance df.resid
## 765.1 801.7 -372.5 745.1 277
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.0683 -0.4836 0.1043 0.6406 1.6873
##
## Random effects:
## Groups Name Variance Std.Dev. Corr
## Pt_ID (Intercept) 0.2243 0.4736
## mQoM 1.3255 1.1513 1.00
## Residual 0.5327 0.7299
## Number of obs: 287, groups: Pt_ID, 110
##
## Fixed effects:
## Estimate Std. Error t value
## (Intercept) -0.15468 0.17801 -0.869
## pieceSchnittke 0.02719 0.10693 0.254
## pieceFolk 0.30661 0.12007 2.554
## groupVirtual -0.06614 0.31748 -0.208
## mQoM 1.14869 1.70581 0.673
## groupVirtual:mQoM -3.05457 2.23831 -1.365
##
## Correlation of Fixed Effects:
## (Intr) pcSchn picFlk grpVrt mQoM
## piecSchnttk -0.235
## pieceFolk 0.125 0.450
## groupVirtul -0.543 -0.037 -0.222
## mQoM -0.829 -0.065 -0.450 0.515
## grpVrtl:mQM 0.621 0.083 0.350 -0.803 -0.760
## optimizer (nloptwrap) convergence code: 0 (OK)
## boundary (singular) fit: see help('isSingular')Check model assumptions
Here is a tutorial that was recommended: https://bodowinter.com/tutorial/bw_LME_tutorial1.pdf https://bodowinter.com/tutorial/bw_LME_tutorial2.pdf
Linearity Because there is no obvious pattern in the residuals, it seems like there is no violation of the linearity assumption.
plot(fitted(piece_group_x_qomM),residuals(piece_group_x_qomM))
Absence of Collinearity If two fixed effects predictors are correlated with each other, they are said to be collinear.
Homoskedasticity This doesn’t appear obviously heteroscedastic but it isn’t perfect either. We can check with Levene’s test for checking variance across groups
leveneTest(data_u_extreme$Absorption, data_u_extreme$group, center = mean) # variance is not different across groups.## Levene's Test for Homogeneity of Variance (center = mean)
## Df F value Pr(>F)
## group 1 0.4561 0.5
## 279Normality of residuals “The normality of residuals
assumption is the one that is least important. Interestingly, many
people seem to think it is the most important one, but it turns
out that linear models are relatively robust against violations of the
assumptions of normality. Researchers differ with respect to how much
weight they put onto
checking this assumption. For example, Gellman and Hill (2007), a famous
book on linear models and mixed models, do not even recommend
diagnostics of the normality assumption (ibid. 46).”
Therefore, it may be ok to violate this assumption.
# The histogram looks skewed with a negative tail.
hist(residuals(piece_group_x_qomM)) # looks skewed slightly
qqnorm(residuals(piece_group_x_qomM))
require(lattice)
qqmath(piece_group_x_qomM, id=0.05) #id: identifies values that may be exerting undue influence on the model (i.e. outliers
Visualize
Figure 4 in the manuscript
#update group label
data_u_extreme$group<-factor(data_u_extreme$group, levels = c("Live", "Virtual"), labels = c("Live", "Livestreaming"))
title = "Relation of Motion & Absorption"
subtitle= "No Extreme Outliers"
# r
p<-data_u_extreme%>%
ggplot(aes(x = mQoM, y = Absorption))+
geom_point(alpha = .5)+
labs(title =title,subtitle = subtitle, x = "Mean QoM", y = "Absorption")+
geom_smooth(method = lm)+
facet_grid(rows = vars(piece), cols = vars(group))+
theme_minimal()+
stat_cor(aes(label = ..r.label..), label.x.npc = .7, color = "blue", geom = "label")#+
#stat_cor(aes(label = ..rr.label..), label.x.npc = .65, color = "blue", geom = "label")+
#stat_cor(aes(label = ..rr.label..), label.x.npc = .65, color = "blue", geom = "label")+
#stat_cor(aes(label = ..r.label..), label.y.npc = .2,label.x.npc = .65, color = "blue", geom = "label")+
#stat_cor(aes(label = paste(..rr.label.., ..p.label.., sep = "~`,`~")), label.x.npc = .6, color = "blue", geom = "label", size = 2.5)+
#stat_cor(aes(label = ..r.label..), label.y.npc = .2,label.x.npc = .65, color = "blue", geom = "label", size = 2.5)
p## `geom_smooth()` using formula 'y ~ x'
graphname<-paste0("../plots/", title,subtitle, ".png")
ggsave(graphname, width = 15, height = 10, units = 'cm', dpi = 500)## `geom_smooth()` using formula 'y ~ x'LME with QoM & Mind-wandering
Test the effects of piece, group, and motion on mind-wandering
dat<-df.full%>%select(Pt_ID, group,contains("Mind-wandering"), contains("QoM"))
df.long<-dat%>%pivot_longer(!c(group, Pt_ID), #make long
names_to = c("var", "piece"),
names_pattern ="(.*)_(.*)",
values_to = "response")
df.wide<-df.long%>%pivot_wider(names_from = var, values_from = response)
df.wide$piece<-factor(df.wide$piece, levels = c("Beethoven", "Schnittke", "Bach", "Folk"))
#factor for the correct facet order
data<-df.wide%>%drop_na() #544 to 287
names(data)[4]<-"MW"Remove extreme outliers
Mind-wandering
outliers<-data %>%
group_by(group, piece) %>%
identify_outliers(MW)
outliers # 3; None are extreme.## # A tibble: 3 × 7
## group piece Pt_ID MW mQoM is.outlier is.extreme
## <fct> <fct> <chr> <dbl> <dbl> <lgl> <lgl>
## 1 Virtual Folk BEQ099 -2.13 0.0914 TRUE FALSE
## 2 Virtual Folk BEQ105 -1.88 0.0809 TRUE FALSE
## 3 Virtual Folk BEQ102 -1.99 0.115 TRUE FALSEextreme<-outliers%>%filter(is.extreme == TRUE)
extreme # none are extreme## # A tibble: 0 × 7
## # … with 7 variables: group <fct>, piece <fct>, Pt_ID <chr>, MW <dbl>,
## # mQoM <dbl>, is.outlier <lgl>, is.extreme <lgl># remove specific instances that are outliers (Pt_ID and piece, because lme can handle missing data so you don't need to remove the whole participant)
# data uten outliers
data_u_outliers<-data%>% # 287 to 284 : looks good!
group_by(group, piece) %>%
filter(!is_outlier(MW))%>%
ungroup()
# data uten extreme
data_u_extreme<-data%>% # 287 to 287 : looks good!
group_by(group, piece) %>%
filter(!is_extreme(MW))%>%
ungroup()QoM
outliers<-data %>%
group_by(group, piece) %>%
identify_outliers(mQoM)
outliers # 21 ## # A tibble: 21 × 7
## group piece Pt_ID MW mQoM is.outlier is.extreme
## <fct> <fct> <chr> <dbl> <dbl> <lgl> <lgl>
## 1 Live Beethoven ADQ010 0.514 0.133 TRUE FALSE
## 2 Live Beethoven ADQ025 0.303 0.148 TRUE FALSE
## 3 Live Beethoven ADQ049 -1.44 0.144 TRUE FALSE
## 4 Live Beethoven ADQ016 -1.51 0.166 TRUE FALSE
## 5 Live Schnittke ADQ049 -1.42 0.170 TRUE FALSE
## 6 Live Schnittke ADQ063 -0.352 0.168 TRUE FALSE
## 7 Live Schnittke ADQ066 0.807 0.177 TRUE FALSE
## 8 Live Schnittke ADQ016 -0.123 0.169 TRUE FALSE
## 9 Live Folk AEQ085 -0.631 0.427 TRUE TRUE
## 10 Live Folk ADQ018 -1.13 0.307 TRUE TRUE
## # … with 11 more rowsextreme_outliers<- outliers%>%filter(is.extreme == TRUE)
extreme_outliers # 6 instances## # A tibble: 6 × 7
## group piece Pt_ID MW mQoM is.outlier is.extreme
## <fct> <fct> <chr> <dbl> <dbl> <lgl> <lgl>
## 1 Live Folk AEQ085 -0.631 0.427 TRUE TRUE
## 2 Live Folk ADQ018 -1.13 0.307 TRUE TRUE
## 3 Virtual Beethoven BEQ103 1.09 0.570 TRUE TRUE
## 4 Virtual Beethoven BDQ092 0.00307 0.460 TRUE TRUE
## 5 Virtual Schnittke BEQ114 -0.515 0.325 TRUE TRUE
## 6 Virtual Folk BEQ106 -0.206 0.486 TRUE TRUEdata_u_outliers<-data_u_outliers%>% # 284 to 264
group_by(group, piece) %>%
filter(!is_outlier(mQoM))%>%
ungroup()
data_u_extreme<-data_u_extreme%>% # 287 to 281 : looks good!
group_by(group, piece) %>%
filter(!is_extreme(mQoM))%>%
ungroup()Test
mw_baseline<-lmer(MW ~ 1 +(1|Pt_ID), data = data, REML = FALSE)
mw_groupM<-lmer(MW ~ 1 + group + (1|Pt_ID), data = data, REML = FALSE)
mw_pieceM<-lmer(MW ~ 1 + group + piece + (1|Pt_ID), data = data, REML = FALSE)
mw_qomM<-lmer(MW ~ 1 + group + piece + mQoM + (1|Pt_ID), data = data, REML = FALSE)
mw_qom_x_piece<-lmer(MW ~ 1 + group + mQoM*piece + (1|Pt_ID), data = data, REML = FALSE)
mw_qom_x_group<-lmer(MW ~ 1 + mQoM*piece + mQoM*group + (1|Pt_ID), data = data, REML = FALSE)
mw_qom_x_piece_x_group<-lmer(MW ~ 1 + mQoM*group*piece + (1|Pt_ID), data = data, REML = FALSE)
anova(mw_baseline, mw_groupM, mw_pieceM, mw_qomM, mw_qom_x_piece, mw_qom_x_group, mw_qom_x_piece_x_group)## Data: data
## Models:
## mw_baseline: MW ~ 1 + (1 | Pt_ID)
## mw_groupM: MW ~ 1 + group + (1 | Pt_ID)
## mw_pieceM: MW ~ 1 + group + piece + (1 | Pt_ID)
## mw_qomM: MW ~ 1 + group + piece + mQoM + (1 | Pt_ID)
## mw_qom_x_piece: MW ~ 1 + group + mQoM * piece + (1 | Pt_ID)
## mw_qom_x_group: MW ~ 1 + mQoM * piece + mQoM * group + (1 | Pt_ID)
## mw_qom_x_piece_x_group: MW ~ 1 + mQoM * group * piece + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df
## mw_baseline 3 731.34 742.31 -362.67 725.34
## mw_groupM 4 732.64 747.28 -362.32 724.64 0.6937 1
## mw_pieceM 6 674.45 696.41 -331.23 662.45 62.1921 2
## mw_qomM 7 676.32 701.94 -331.16 662.32 0.1279 1
## mw_qom_x_piece 9 678.44 711.38 -330.22 660.44 1.8815 2
## mw_qom_x_group 10 676.49 713.08 -328.24 656.49 3.9523 1
## mw_qom_x_piece_x_group 14 681.96 733.19 -326.98 653.96 2.5329 4
## Pr(>Chisq)
## mw_baseline
## mw_groupM 0.40492
## mw_pieceM 3.127e-14 ***
## mw_qomM 0.72062
## mw_qom_x_piece 0.39034
## mw_qom_x_group 0.04681 *
## mw_qom_x_piece_x_group 0.63876
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1Refit with only sig predictors: This indicates that the best model is the one with a main effect of piece.
mw_baseline<-lmer(MW ~ 1 +(1|Pt_ID), data = data, REML = FALSE)
mw_groupM<-lmer(MW ~ 1 + group + (1|Pt_ID), data = data, REML = FALSE)
anova(mw_baseline, mw_groupM) # NS## Data: data
## Models:
## mw_baseline: MW ~ 1 + (1 | Pt_ID)
## mw_groupM: MW ~ 1 + group + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mw_baseline 3 731.34 742.31 -362.67 725.34
## mw_groupM 4 732.64 747.28 -362.32 724.64 0.6937 1 0.4049mw_pieceM<-lmer(MW ~ 1 + piece + (1|Pt_ID), data = data, REML = FALSE)
anova(mw_baseline, mw_pieceM) # sig!## Data: data
## Models:
## mw_baseline: MW ~ 1 + (1 | Pt_ID)
## mw_pieceM: MW ~ 1 + piece + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mw_baseline 3 731.34 742.31 -362.67 725.34
## mw_pieceM 5 672.67 690.97 -331.34 662.67 62.661 2 2.473e-14 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1mw_piecexgroup<-lmer(MW ~ 1 + piece*group + (1|Pt_ID), data = data, REML = FALSE)
anova(mw_pieceM, mw_piecexgroup) # NS## Data: data
## Models:
## mw_pieceM: MW ~ 1 + piece + (1 | Pt_ID)
## mw_piecexgroup: MW ~ 1 + piece * group + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mw_pieceM 5 672.67 690.97 -331.34 662.67
## mw_piecexgroup 8 677.95 707.22 -330.97 661.95 0.7274 3 0.8667mw_qomM<-lmer(MW ~ 1 + piece + mQoM + (1|Pt_ID), data = data, REML = FALSE)
anova(mw_pieceM, mw_qomM) # NS## Data: data
## Models:
## mw_pieceM: MW ~ 1 + piece + (1 | Pt_ID)
## mw_qomM: MW ~ 1 + piece + mQoM + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mw_pieceM 5 672.67 690.97 -331.34 662.67
## mw_qomM 6 674.45 696.41 -331.23 662.45 0.2224 1 0.6372mw_qomXpiece<-lmer(MW ~ 1 + piece*mQoM + (1|Pt_ID), data = data, REML = FALSE)
anova(mw_pieceM, mw_qomXpiece) # NS## Data: data
## Models:
## mw_pieceM: MW ~ 1 + piece + (1 | Pt_ID)
## mw_qomXpiece: MW ~ 1 + piece * mQoM + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mw_pieceM 5 672.67 690.97 -331.34 662.67
## mw_qomXpiece 8 676.52 705.79 -330.26 660.52 2.1574 3 0.5404mw_piece_qomXgroup<-lmer(MW ~ 1 + piece + mQoM*group + (1|Pt_ID), data = data, REML = FALSE)
anova(mw_pieceM, mw_piece_qomXgroup) # NS## Data: data
## Models:
## mw_pieceM: MW ~ 1 + piece + (1 | Pt_ID)
## mw_piece_qomXgroup: MW ~ 1 + piece + mQoM * group + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mw_pieceM 5 672.67 690.97 -331.34 662.67
## mw_piece_qomXgroup 8 675.78 705.06 -329.89 659.78 2.8935 3 0.4083mw_qomXpiece_qomXgroup<-lmer(MW ~ 1 + piece*mQoM + mQoM*group + (1|Pt_ID), data = data, REML = FALSE)
anova(mw_pieceM, mw_qomXpiece_qomXgroup) # NS## Data: data
## Models:
## mw_pieceM: MW ~ 1 + piece + (1 | Pt_ID)
## mw_qomXpiece_qomXgroup: MW ~ 1 + piece * mQoM + mQoM * group + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mw_pieceM 5 672.67 690.97 -331.34 662.67
## mw_qomXpiece_qomXgroup 10 676.49 713.08 -328.24 656.49 6.186 5 0.2885mw_qom_x_piece_x_group<-lmer(MW ~ 1 + mQoM*group*piece + (1|Pt_ID), data = data, REML = FALSE)
anova(mw_pieceM, mw_qom_x_piece_x_group) # NS## Data: data
## Models:
## mw_pieceM: MW ~ 1 + piece + (1 | Pt_ID)
## mw_qom_x_piece_x_group: MW ~ 1 + mQoM * group * piece + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mw_pieceM 5 672.67 690.97 -331.34 662.67
## mw_qom_x_piece_x_group 14 681.96 733.19 -326.98 653.96 8.7189 9 0.4636Examine model
summary(mw_qom_x_group) # effect of piece persists, schnittke and folk both have less mind-wandering than beethoven. virtual x qom ## Linear mixed model fit by maximum likelihood ['lmerMod']
## Formula: MW ~ 1 + mQoM * piece + mQoM * group + (1 | Pt_ID)
## Data: data
##
## AIC BIC logLik deviance df.resid
## 676.5 713.1 -328.2 656.5 277
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -2.57283 -0.50138 -0.03004 0.54021 2.22239
##
## Random effects:
## Groups Name Variance Std.Dev.
## Pt_ID (Intercept) 0.5136 0.7166
## Residual 0.3061 0.5533
## Number of obs: 287, groups: Pt_ID, 110
##
## Fixed effects:
## Estimate Std. Error t value
## (Intercept) 0.5745 0.1945 2.954
## mQoM -2.8579 1.8121 -1.577
## pieceSchnittke -0.7977 0.2043 -3.904
## pieceFolk -0.7857 0.1851 -4.245
## groupVirtual -0.3897 0.2955 -1.319
## mQoM:pieceSchnittke 3.3710 1.8680 1.805
## mQoM:pieceFolk 1.4314 1.4914 0.960
## mQoM:groupVirtual 3.7393 1.8742 1.995
##
## Correlation of Fixed Effects:
## (Intr) mQoM pcSchn picFlk grpVrt mQM:pS mQM:pF
## mQoM -0.864
## piecSchnttk -0.372 0.311
## pieceFolk -0.466 0.412 0.366
## groupVirtul -0.571 0.510 0.177 0.125
## mQM:pcSchnt 0.339 -0.365 -0.917 -0.310 -0.207
## mQoM:picFlk 0.604 -0.679 -0.340 -0.864 -0.259 0.380
## mQM:grpVrtl 0.696 -0.816 -0.199 -0.209 -0.753 0.252 0.440plot(mw_qom_x_group)
summary(mw_pieceM)## Linear mixed model fit by maximum likelihood ['lmerMod']
## Formula: MW ~ 1 + piece + (1 | Pt_ID)
## Data: data
##
## AIC BIC logLik deviance df.resid
## 672.7 691.0 -331.3 662.7 282
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -2.55899 -0.49850 -0.04884 0.60233 2.25616
##
## Random effects:
## Groups Name Variance Std.Dev.
## Pt_ID (Intercept) 0.5171 0.7191
## Residual 0.3148 0.5611
## Number of obs: 287, groups: Pt_ID, 110
##
## Fixed effects:
## Estimate Std. Error t value
## (Intercept) 0.32725 0.08868 3.690
## pieceSchnittke -0.47304 0.08224 -5.752
## pieceFolk -0.68668 0.08293 -8.281
##
## Correlation of Fixed Effects:
## (Intr) pcSchn
## piecSchnttk -0.426
## pieceFolk -0.432 0.470plot(mw_pieceM)
data %>%
group_by(group, piece) %>%
get_summary_stats(MW, type = "mean_sd")## # A tibble: 6 × 6
## group piece variable n mean sd
## <fct> <fct> <chr> <dbl> <dbl> <dbl>
## 1 Live Beethoven MW 79 0.333 1.02
## 2 Live Schnittke MW 77 -0.182 0.892
## 3 Live Folk MW 76 -0.397 0.859
## 4 Virtual Beethoven MW 24 0.385 0.809
## 5 Virtual Schnittke MW 15 -0.169 0.996
## 6 Virtual Folk MW 16 -0.365 0.959bxp <- ggboxplot(
data, x = "piece", y = "MW",
color = "group", palette = "jco"
)
bxp
Check model assumptions
Here is a tutorial that was recommended: https://bodowinter.com/tutorial/bw_LME_tutorial1.pdf https://bodowinter.com/tutorial/bw_LME_tutorial2.pdf
Linearity Because there is no obvious pattern in the residuals, it seems like there is no violation of the linearity assumption.
plot(fitted(mw_pieceM),residuals(mw_pieceM))
Absence of Collinearity If two fixed effects predictors are correlated with each other, they are said to be collinear.
Homoskedasticity This doesn’t appear obviously heteroscedastic but it isn’t perfect either.
Normality of residuals “The normality of residuals
assumption is the one that is least important. Interestingly, many
people seem to think it is the most important one, but it turns
out that linear models are relatively robust against violations of the
assumptions of normality. Researchers differ with respect to how much
weight they put onto
checking this assumption. For example, Gellman and Hill (2007), a famous
book on linear models and mixed models, do not even recommend
diagnostics of the normality assumption (ibid. 46).”
Therefore, it may be ok to violate this assumption.
# The histogram looks skewed with a negative tail.
hist(residuals(mw_pieceM))
qqnorm(residuals(mw_pieceM))
require(lattice)
qqmath(mw_pieceM, id=0.05) #id: identifies values that may be exerting undue influence on the model (i.e. outliers
Without extreme outliers
Fit model
mw_baseline<-lmer(MW ~ 1 +(1|Pt_ID), data = data_u_extreme, REML = FALSE)
mw_groupM<-lmer(MW ~ 1 + group + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
mw_pieceM<-lmer(MW ~ 1 + group + piece + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
mw_qomM<-lmer(MW ~ 1 + group + piece + mQoM + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
mw_qom_x_piece<-lmer(MW ~ 1 + group + mQoM*piece + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
mw_qom_x_group<-lmer(MW ~ 1 + mQoM*piece + mQoM*group + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
mw_qom_x_piece_x_group<-lmer(MW ~ 1 + mQoM*group*piece + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(mw_baseline, mw_groupM, mw_pieceM, mw_qomM, mw_qom_x_piece, mw_qom_x_group, mw_qom_x_piece_x_group)## Data: data_u_extreme
## Models:
## mw_baseline: MW ~ 1 + (1 | Pt_ID)
## mw_groupM: MW ~ 1 + group + (1 | Pt_ID)
## mw_pieceM: MW ~ 1 + group + piece + (1 | Pt_ID)
## mw_qomM: MW ~ 1 + group + piece + mQoM + (1 | Pt_ID)
## mw_qom_x_piece: MW ~ 1 + group + mQoM * piece + (1 | Pt_ID)
## mw_qom_x_group: MW ~ 1 + mQoM * piece + mQoM * group + (1 | Pt_ID)
## mw_qom_x_piece_x_group: MW ~ 1 + mQoM * group * piece + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df
## mw_baseline 3 719.14 730.05 -356.57 713.14
## mw_groupM 4 720.54 735.09 -356.27 712.54 0.5986 1
## mw_pieceM 6 665.85 687.68 -326.93 653.85 58.6875 2
## mw_qomM 7 667.03 692.49 -326.51 653.03 0.8262 1
## mw_qom_x_piece 9 669.27 702.01 -325.63 651.27 1.7570 2
## mw_qom_x_group 10 663.86 700.25 -321.93 643.86 7.4063 1
## mw_qom_x_piece_x_group 14 671.14 722.07 -321.57 643.14 0.7262 4
## Pr(>Chisq)
## mw_baseline
## mw_groupM 0.439130
## mw_pieceM 1.804e-13 ***
## mw_qomM 0.363363
## mw_qom_x_piece 0.415410
## mw_qom_x_group 0.006499 **
## mw_qom_x_piece_x_group 0.948062
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1Refit with only sig predictors: This indicates that the best model is the one with a main effect of piece.
mw_baseline<-lmer(MW ~ 1 +(1|Pt_ID), data = data_u_extreme, REML = FALSE)
mw_groupM<-lmer(MW ~ 1 + group + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(mw_baseline, mw_groupM) # NS## Data: data_u_extreme
## Models:
## mw_baseline: MW ~ 1 + (1 | Pt_ID)
## mw_groupM: MW ~ 1 + group + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mw_baseline 3 719.14 730.05 -356.57 713.14
## mw_groupM 4 720.54 735.09 -356.27 712.54 0.5986 1 0.4391mw_pieceM<-lmer(MW ~ 1 + piece + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(mw_baseline, mw_pieceM) # sig!## Data: data_u_extreme
## Models:
## mw_baseline: MW ~ 1 + (1 | Pt_ID)
## mw_pieceM: MW ~ 1 + piece + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mw_baseline 3 719.14 730.05 -356.57 713.14
## mw_pieceM 5 664.07 682.26 -327.03 654.07 59.069 2 1.49e-13 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1mw_piecexgroup<-lmer(MW ~ 1 + piece*group + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(mw_pieceM, mw_piecexgroup) # NS## Data: data_u_extreme
## Models:
## mw_pieceM: MW ~ 1 + piece + (1 | Pt_ID)
## mw_piecexgroup: MW ~ 1 + piece * group + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mw_pieceM 5 664.07 682.26 -327.03 654.07
## mw_piecexgroup 8 669.46 698.57 -326.73 653.46 0.6089 3 0.8944mw_qomM<-lmer(MW ~ 1 + piece + mQoM + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(mw_pieceM, mw_qomM) # NS## Data: data_u_extreme
## Models:
## mw_pieceM: MW ~ 1 + piece + (1 | Pt_ID)
## mw_qomM: MW ~ 1 + piece + mQoM + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mw_pieceM 5 664.07 682.26 -327.03 654.07
## mw_qomM 6 665.06 686.89 -326.53 653.06 1.0124 1 0.3143mw_qomXpiece<-lmer(MW ~ 1 + piece*mQoM + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(mw_pieceM, mw_qomXpiece) # NS## Data: data_u_extreme
## Models:
## mw_pieceM: MW ~ 1 + piece + (1 | Pt_ID)
## mw_qomXpiece: MW ~ 1 + piece * mQoM + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mw_pieceM 5 664.07 682.26 -327.03 654.07
## mw_qomXpiece 8 667.34 696.44 -325.67 651.34 2.7322 3 0.4348mw_piece_qomXgroup<-lmer(MW ~ 1 + piece + mQoM*group + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(mw_pieceM, mw_piece_qomXgroup) # NS## Data: data_u_extreme
## Models:
## mw_pieceM: MW ~ 1 + piece + (1 | Pt_ID)
## mw_piece_qomXgroup: MW ~ 1 + piece + mQoM * group + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mw_pieceM 5 664.07 682.26 -327.03 654.07
## mw_piece_qomXgroup 8 664.85 693.96 -324.43 648.85 5.216 3 0.1566mw_qomXpiece_qomXgroup<-lmer(MW ~ 1 + piece*mQoM + mQoM*group + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(mw_pieceM, mw_qomXpiece_qomXgroup) # NS but trending## Data: data_u_extreme
## Models:
## mw_pieceM: MW ~ 1 + piece + (1 | Pt_ID)
## mw_qomXpiece_qomXgroup: MW ~ 1 + piece * mQoM + mQoM * group + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mw_pieceM 5 664.07 682.26 -327.03 654.07
## mw_qomXpiece_qomXgroup 10 663.86 700.25 -321.93 643.86 10.206 5 0.0696
##
## mw_pieceM
## mw_qomXpiece_qomXgroup .
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1mw_qom_x_piece_x_group<-lmer(MW ~ 1 + mQoM*group*piece + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(mw_pieceM, mw_qom_x_piece_x_group) # NS## Data: data_u_extreme
## Models:
## mw_pieceM: MW ~ 1 + piece + (1 | Pt_ID)
## mw_qom_x_piece_x_group: MW ~ 1 + mQoM * group * piece + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mw_pieceM 5 664.07 682.26 -327.03 654.07
## mw_qom_x_piece_x_group 14 671.14 722.07 -321.57 643.14 10.932 9 0.2804Visualize
#update group label
data_u_extreme$group<-factor(data_u_extreme$group, levels = c("Live", "Virtual"), labels = c("Live", "Livestreaming"))
title = "Relation of Motion & Mind-wandering"
subtitle = "Without extreme outliers"
#r2
p<-data_u_extreme%>%
ggplot(aes(x = mQoM, y = MW))+
geom_point(alpha = .5)+
labs(title =title,subtitle = subtitle, x = "Mean QoM", y = "Mind-wandering")+
geom_smooth(method = lm)+
facet_grid(rows = vars(piece), cols = vars(group))+
theme_minimal()+
stat_cor(aes(label = ..r.label..), label.x.npc = .7, color = "blue", geom = "label")#+
#stat_cor(aes(label = ..rr.label..), label.x.npc = .65, color = "blue", geom = "label")
#stat_cor(aes(label = paste(..rr.label.., ..p.label.., sep = "~`,`~")), label.x.npc = .6, color = "blue", geom = "label", size = 2.5)+
#stat_cor(aes(label = ..r.label..), label.y.npc = .2,label.x.npc = .65, color = "blue", geom = "label", size = 2.5)
p## `geom_smooth()` using formula 'y ~ x'
graphname<-paste0("../plots/", title, ".png")
ggsave(graphname, width = 15, height = 10, units = 'cm', dpi = 500)## `geom_smooth()` using formula 'y ~ x'3.6.2 LME with Stilling & Absorption
dat<-df.full%>%select(Pt_ID, EC,contains("Absorption"), contains("Stilling"))%>%select(-Stilling_FullConcert, -Stilling_Bach)
df.long<-dat%>%pivot_longer(!c(EC, Pt_ID), #make long
names_to = c("var", "piece"),
names_pattern ="(.*)_(.*)",
values_to = "response")
df.wide<-df.long%>%pivot_wider(names_from = var, values_from = response)
df.wide$piece<-factor(df.wide$piece, levels = c("Beethoven", "Schnittke", "Bach", "Folk"))
#factor for the correct facet order
data<-df.wide%>%drop_na() #408 to 232Remove extreme outliers
Absorption
outliers<-data %>%
group_by(piece) %>%
identify_outliers(Absorption)
outliers # 1; None are extreme.## # A tibble: 1 × 7
## piece Pt_ID EC Absorption Stilling is.outlier is.extreme
## <fct> <chr> <dbl> <dbl> <dbl> <lgl> <lgl>
## 1 Schnittke ADQ003 4.43 -2.79 0.581 TRUE FALSEextreme<-outliers%>%filter(is.extreme == TRUE)
extreme # none are extreme## # A tibble: 0 × 7
## # … with 7 variables: piece <fct>, Pt_ID <chr>, EC <dbl>, Absorption <dbl>,
## # Stilling <dbl>, is.outlier <lgl>, is.extreme <lgl># remove specific instances that are outliers (Pt_ID and piece, because lme can handle missing data so you don't need to remove the whole participant)
# data uten outliers
data_u_outliers<-data%>% # 232 to 231 : looks good!
group_by(piece) %>%
filter(!is_outlier(Absorption))%>%
ungroup()
# data uten extreme
data_u_extreme<-data%>% # 232 to 232 : looks good!
group_by(piece) %>%
filter(!is_extreme(Absorption))%>%
ungroup()Stilling
data%>%summarize(mean = mean(Stilling))## # A tibble: 1 × 1
## mean
## <dbl>
## 1 0.547outliers<-data %>%
group_by(piece) %>%
identify_outliers(Stilling)
outliers # 3## # A tibble: 3 × 7
## piece Pt_ID EC Absorption Stilling is.outlier is.extreme
## <fct> <chr> <dbl> <dbl> <dbl> <lgl> <lgl>
## 1 Folk ADQ058 3.29 1.02 0.154 TRUE TRUE
## 2 Folk ADQ029 4.86 1.56 0.205 TRUE FALSE
## 3 Folk ADQ022 5 0.290 0.256 TRUE FALSEextreme_outliers<- outliers%>%filter(is.extreme == TRUE)
extreme_outliers # 1## # A tibble: 1 × 7
## piece Pt_ID EC Absorption Stilling is.outlier is.extreme
## <fct> <chr> <dbl> <dbl> <dbl> <lgl> <lgl>
## 1 Folk ADQ058 3.29 1.02 0.154 TRUE TRUEdata_u_outliers<-data_u_outliers%>% # 231 to 228
group_by(piece) %>%
filter(!is_outlier(Stilling))%>%
ungroup()
data_u_extreme<-data_u_extreme%>% # 232 to 231 : looks good!
group_by(piece) %>%
filter(!is_extreme(Stilling))%>%
ungroup()Fit model
baseline<-lmer(Absorption ~ 1 +(1|Pt_ID), data = data, REML = FALSE)
pieceM<-lmer(Absorption ~ 1 + piece + (1|Pt_ID), data = data, REML = FALSE) # sig
stillM<-lmer(Absorption ~ 1 + piece + Stilling + (1|Pt_ID), data = data, REML = FALSE)
intxnM<-lmer(Absorption ~ 1 + piece * Stilling + (1|Pt_ID), data = data, REML = FALSE)
anova(baseline, pieceM, stillM, intxnM)## Data: data
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## pieceM: Absorption ~ 1 + piece + (1 | Pt_ID)
## stillM: Absorption ~ 1 + piece + Stilling + (1 | Pt_ID)
## intxnM: Absorption ~ 1 + piece * Stilling + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 621.26 631.60 -307.63 615.26
## pieceM 5 616.15 633.39 -303.08 606.15 9.1088 2 0.01052 *
## stillM 6 616.92 637.60 -302.46 604.92 1.2345 1 0.26654
## intxnM 8 617.63 645.21 -300.82 601.63 3.2857 2 0.19343
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1stillM<-lmer(Absorption ~ 1 + Stilling + (1|Pt_ID), data = data, REML = FALSE) #NS
anova(baseline, stillM) ## Data: data
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## stillM: Absorption ~ 1 + Stilling + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 621.26 631.60 -307.63 615.26
## stillM 4 621.73 635.52 -306.87 613.73 1.531 1 0.216Try without extreme
Extreme = < Q1 - 3* IQR or > Q3 + 3* IQR
baseline<-lmer(Absorption ~ 1 +(1|Pt_ID), data = data_u_extreme, REML = FALSE)
pieceM<-lmer(Absorption ~ 1 + piece + (1|Pt_ID), data = data_u_extreme, REML = FALSE) # sig
stillM<-lmer(Absorption ~ 1 + piece + Stilling + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
intxnM<-lmer(Absorption ~ 1 + piece * Stilling + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(baseline, pieceM, stillM, intxnM) # NS## Data: data_u_extreme
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## pieceM: Absorption ~ 1 + piece + (1 | Pt_ID)
## stillM: Absorption ~ 1 + piece + Stilling + (1 | Pt_ID)
## intxnM: Absorption ~ 1 + piece * Stilling + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 618.02 628.35 -306.01 612.02
## pieceM 5 613.62 630.83 -301.81 603.62 8.4074 2 0.01494 *
## stillM 6 613.58 634.23 -300.79 601.58 2.0397 1 0.15324
## intxnM 8 615.30 642.84 -299.65 599.30 2.2804 2 0.31975
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1stillM<-lmer(Absorption ~ 1 + Stilling + (1|Pt_ID), data = data_u_extreme, REML = FALSE)
anova(baseline, stillM) #NS## Data: data_u_extreme
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## stillM: Absorption ~ 1 + Stilling + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 618.02 628.35 -306.01 612.02
## stillM 4 617.38 631.15 -304.69 609.38 2.6397 1 0.1042Random slope of stilling as well
Fit model
baseline<-lmer(Absorption ~ 1 +(1+Stilling|Pt_ID), data = data, REML = FALSE)
pieceM<-lmer(Absorption ~ 1 + piece + (1+Stilling|Pt_ID), data = data, REML = FALSE) # sig
stillM<-lmer(Absorption ~ 1 + piece + Stilling + (1+Stilling|Pt_ID), data = data, REML = FALSE)
intxnM<-lmer(Absorption ~ 1 + piece * Stilling + (1+Stilling|Pt_ID), data = data, REML = FALSE)
anova(baseline, pieceM, stillM, intxnM)## Data: data
## Models:
## baseline: Absorption ~ 1 + (1 + Stilling | Pt_ID)
## pieceM: Absorption ~ 1 + piece + (1 + Stilling | Pt_ID)
## stillM: Absorption ~ 1 + piece + Stilling + (1 + Stilling | Pt_ID)
## intxnM: Absorption ~ 1 + piece * Stilling + (1 + Stilling | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 625.19 642.42 -307.59 615.19
## pieceM 7 620.08 644.21 -303.04 606.08 9.1068 2 0.01053 *
## stillM 8 620.91 648.49 -302.46 604.91 1.1656 1 0.28031
## intxnM 10 621.10 655.56 -300.55 601.10 3.8172 2 0.14829
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1stillM<-lmer(Absorption ~ 1 + Stilling + (1+Stilling|Pt_ID), data = data, REML = FALSE) #MODEL FAILED TO CONVERGE## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, :
## Model failed to converge with max|grad| = 0.00465113 (tol = 0.002, component 1)anova(baseline, stillM) ## Data: data
## Models:
## baseline: Absorption ~ 1 + (1 + Stilling | Pt_ID)
## stillM: Absorption ~ 1 + Stilling + (1 + Stilling | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 625.19 642.42 -307.59 615.19
## stillM 6 625.73 646.41 -306.87 613.73 1.4572 1 0.2274Try without extreme
Extreme = < Q1 - 3* IQR or > Q3 + 3* IQR
baseline<-lmer(Absorption ~ 1 +(1+Stilling|Pt_ID), data = data_u_extreme, REML = FALSE) # is singular## boundary (singular) fit: see help('isSingular')pieceM<-lmer(Absorption ~ 1 + piece + (1+Stilling|Pt_ID), data = data_u_extreme, REML = FALSE) # sig # is singular## boundary (singular) fit: see help('isSingular')stillM<-lmer(Absorption ~ 1 + piece + Stilling + (1+Stilling|Pt_ID), data = data_u_extreme, REML = FALSE)
intxnM<-lmer(Absorption ~ 1 + piece * Stilling + (1+Stilling|Pt_ID), data = data_u_extreme, REML = FALSE) # is singular## boundary (singular) fit: see help('isSingular')anova(baseline, pieceM, stillM, intxnM) # NS## Data: data_u_extreme
## Models:
## baseline: Absorption ~ 1 + (1 + Stilling | Pt_ID)
## pieceM: Absorption ~ 1 + piece + (1 + Stilling | Pt_ID)
## stillM: Absorption ~ 1 + piece + Stilling + (1 + Stilling | Pt_ID)
## intxnM: Absorption ~ 1 + piece * Stilling + (1 + Stilling | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 621.99 639.20 -305.99 611.99
## pieceM 7 617.58 641.68 -301.79 603.58 8.4068 2 0.01494 *
## stillM 8 617.58 645.12 -300.79 601.58 2.0033 1 0.15696
## intxnM 10 619.04 653.46 -299.52 599.04 2.5395 2 0.28090
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1stillM<-lmer(Absorption ~ 1 + Stilling + (1+Stilling|Pt_ID), data = data_u_extreme, REML = FALSE) # is singular## boundary (singular) fit: see help('isSingular')anova(baseline, stillM) #NS## Data: data_u_extreme
## Models:
## baseline: Absorption ~ 1 + (1 + Stilling | Pt_ID)
## stillM: Absorption ~ 1 + Stilling + (1 + Stilling | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 621.99 639.20 -305.99 611.99
## stillM 6 621.37 642.03 -304.69 609.37 2.6114 1 0.1061Check model assumptions
Here is a tutorial that was recommended: https://bodowinter.com/tutorial/bw_LME_tutorial1.pdf https://bodowinter.com/tutorial/bw_LME_tutorial2.pdf
Linearity Because there is no obvious pattern in the residuals, it seems like there is no violation of the linearity assumption.
plot(fitted(pieceM),residuals(pieceM))
plot(fitted(stillM),residuals(stillM))
Absence of Collinearity If two fixed effects predictors are correlated with each other, they are said to be collinear.
Homoskedasticity This doesn’t appear obviously heteroscedastic but it isn’t perfect either.
Normality of residuals “The normality of residuals
assumption is the one that is least important. Interestingly, many
people seem to think it is the most important one, but it turns
out that linear models are relatively robust against violations of the
assumptions of normality. Researchers differ with respect to how much
weight they put onto
checking this assumption. For example, Gellman and Hill (2007), a famous
book on linear models and mixed models, do not even recommend
diagnostics of the normality assumption (ibid. 46).”
Therefore, it may be ok to violate this assumption.
# The histogram looks skewed with a negative tail.
hist(residuals(pieceM)) # still looks skewed
qqnorm(residuals(pieceM))
require(lattice)
qqmath(pieceM, id=0.05) #id: identifies values that may be exerting undue influence on the model (i.e. outliers
# The histogram looks skewed with a negative tail.
hist(residuals(stillM)) # still looks skewed
qqnorm(residuals(stillM))
require(lattice)
qqmath(stillM, id=0.05) #id: identifies values that may be exerting undue influence on the model (i.e. outliers
Visualize
title = "Relation of Stilling & Absorption"
#subtitle= "No Extreme Outliers"
# r
p<-data%>%
ggplot(aes(x = Stilling, y = Absorption))+
geom_point(alpha = .5)+
labs(title =title,x = "Stilling", y = "Absorption")+
geom_smooth(method = lm)+
facet_grid(rows = vars(piece))+
theme_minimal()+
stat_cor(aes(label = ..r.label..), label.x.npc = .7, color = "blue", geom = "label")#+
#stat_cor(aes(label = ..rr.label..), label.x.npc = .65, color = "blue", geom = "label")+
#stat_cor(aes(label = ..rr.label..), label.x.npc = .65, color = "blue", geom = "label")+
#stat_cor(aes(label = ..r.label..), label.y.npc = .2,label.x.npc = .65, color = "blue", geom = "label")+
#stat_cor(aes(label = paste(..rr.label.., ..p.label.., sep = "~`,`~")), label.x.npc = .6, color = "blue", geom = "label", size = 2.5)+
#stat_cor(aes(label = ..r.label..), label.y.npc = .2,label.x.npc = .65, color = "blue", geom = "label", size = 2.5)
p## `geom_smooth()` using formula 'y ~ x'
graphname<-paste0("../plots/", title,subtitle, ".png")
ggsave(graphname, width = 15, height = 10, units = 'cm', dpi = 500)## `geom_smooth()` using formula 'y ~ x'3.6.3 Perceived movement
- What is the relation between absorption and perceived movement of self and others as well as quantified movement of self and other?
Mixed ANOVA approach
NOTE: the “perceived movement” responses were not continuous, but some were ordinal and some were categorical.Therefore, I should not use methods that rely on continuous data.
First, I can visualize the relation between absorption and awareness of motion to visually inspect for differences. If none are obvious, there might be no point in conducting a test anyways.
** Questions and Response Options **
Q1: Were you aware of your physical body during this piece? Options: Not
at all, Rarely, Intermittently, Continuously Q2: Were you aware of your
own physical movement during this piece? If so, how much did you move
relative to your own usual behaviour at this kind of concert? Options:
Not aware of movement, Yes and I moved less than usual, Yes and I moved
a normal amount, Yes and I moved more than usual Q3: Were you aware of
others in the audience moving during the piece? If so, how much were
they moving relative to the usual behaviour you observe at this kind of
concert? Options: Not aware of others’ movement, Yes and they moved less
than usual, Yes and they moved a normal amount, Yes and they moved more
than usual
movement_items<-c(
"aware_body_Beethoven",
"aware_movement_Beethoven",
"aware_others_moving_Beethoven",
"aware_body_Schnittke",
"aware_movement_Schnittke",
"aware_others_moving_Schnittke",
"aware_body_Folk",
"aware_movement_Folk",
"aware_others_moving_Folk")
df_movement<-df.full%>%select("Pt_ID",group, contains(movement_items))
df_move.long<-df_movement%>%pivot_longer(!c(Pt_ID,group),
names_to = c("question", "piece"),
names_pattern ="(.*)_(.*)",
values_to = "response")
df_move.wide<-df_move.long%>%pivot_wider(names_from = question, values_from = response)Assign Types factor, ordered factor, and numeric
# aware body
ordering = c("Not at all","Rarely", "Intermittently", "Continuously")
## factor
df_move.wide$aware_body_f<-factor(df_move.wide$aware_body, levels = ordering)
## ordered factor
df_move.wide$aware_body_of<-factor(df_move.wide$aware_body, levels = ordering, ordered = TRUE)
## numeric
df_move.wide$aware_body_n<-as.numeric(df_move.wide$aware_body_f)
# aware movement
ordering =c("Not aware of movement","Yes and I moved less than usual", "Yes and I moved a normal amount", "Yes and I moved more than usual")
## factor
df_move.wide$aware_movement_f<- factor(df_move.wide$aware_movement, levels = ordering)
## ordered factor
df_move.wide$aware_movement_of<- factor(df_move.wide$aware_movement, levels = ordering, ordered = TRUE)
## numeric
df_move.wide$aware_movement_n<-as.numeric(df_move.wide$aware_movement_f)
# aware others movement
ordering =c("Not aware of others' movement", "Yes and they moved less than usual", "Yes and they moved a normal amount","Yes and they moved more than usual")
## factor
df_move.wide$aware_others_moving_f<- factor(df_move.wide$aware_others_moving, levels = ordering)
## ordered factor
df_move.wide$aware_others_moving_of<- factor(df_move.wide$aware_others_moving, levels = ordering, ordered = TRUE)
## numeric
df_move.wide$aware_others_moving_n<-as.numeric(df_move.wide$aware_others_moving_f)
describe(df_move.wide)## vars n mean sd median trimmed mad min max range
## Pt_ID* 1 408 68.50 39.31 68.5 68.50 50.41 1 136 135
## group* 2 408 1.33 0.47 1.0 1.29 0.00 1 2 1
## piece* 3 408 2.00 0.82 2.0 2.00 1.48 1 3 2
## aware_body* 4 374 2.73 0.77 3.0 2.74 0.00 1 4 3
## aware_movement* 5 373 6.60 0.96 7.0 6.63 1.48 5 8 3
## aware_others_moving* 6 365 9.72 1.10 9.0 9.53 0.00 9 12 3
## aware_body_f* 7 374 2.73 0.77 3.0 2.74 0.00 1 4 3
## aware_body_of* 8 374 2.73 0.77 3.0 2.74 0.00 1 4 3
## aware_body_n 9 374 2.73 0.77 3.0 2.74 0.00 1 4 3
## aware_movement_f* 10 373 2.60 0.96 3.0 2.63 1.48 1 4 3
## aware_movement_of* 11 373 2.60 0.96 3.0 2.63 1.48 1 4 3
## aware_movement_n 12 373 2.60 0.96 3.0 2.63 1.48 1 4 3
## aware_others_moving_f* 13 365 1.72 1.10 1.0 1.53 0.00 1 4 3
## aware_others_moving_of* 14 365 1.72 1.10 1.0 1.53 0.00 1 4 3
## aware_others_moving_n 15 365 1.72 1.10 1.0 1.53 0.00 1 4 3
## skew kurtosis se
## Pt_ID* 0.00 -1.21 1.95
## group* 0.72 -1.49 0.02
## piece* 0.00 -1.51 0.04
## aware_body* -0.26 -0.26 0.04
## aware_movement* -0.23 -0.88 0.05
## aware_others_moving* 1.15 -0.29 0.06
## aware_body_f* -0.26 -0.26 0.04
## aware_body_of* -0.26 -0.26 0.04
## aware_body_n -0.26 -0.26 0.04
## aware_movement_f* -0.23 -0.88 0.05
## aware_movement_of* -0.23 -0.88 0.05
## aware_movement_n -0.23 -0.88 0.05
## aware_others_moving_f* 1.15 -0.29 0.06
## aware_others_moving_of* 1.15 -0.29 0.06
## aware_others_moving_n 1.15 -0.29 0.06# combine with absorption
df_move_abs<-full_join(df_move.wide, absorbed_factors, by = c("Pt_ID", "piece"))
## factor order piece
df_move_abs$piece<-factor(df_move_abs$piece, levels = c("Beethoven", "Schnittke", "Folk"))Visualize
Aware_body
ADQ062 has NAs from having missed two pages of the survey (the after beethoven movement awareness is missing)
df_move_abs%>%
filter(! is.na(aware_body_f))%>%
ggplot(aes(x= aware_body_f, y = Absorption, fill = aware_body_f))+
geom_violin()+
geom_jitter()+
scale_fill_brewer(palette = "Dark2")+
stat_summary(fun.data=mean_sdl, mult = 1,
geom = "pointrange", color = "black")+
facet_grid(cols = vars(piece), rows = vars(group))+
theme_minimal()+
theme(legend.position = "bottom")+
theme(axis.text.x = element_blank())+
theme(axis.title.x = element_blank())+
labs(title = "Aware of Own Body", fill = "Aware Body")## Warning: Ignoring unknown parameters: mult## Warning: Removed 16 rows containing non-finite values (stat_ydensity).## Warning: Removed 16 rows containing non-finite values (stat_summary).## Warning: Removed 16 rows containing missing values (geom_point).
Aware of own movement
df_move_abs%>%
filter(! aware_movement_f==0)%>% filter(! is.na(aware_movement_f))%>%
ggplot(aes(x= aware_movement_f, y = Absorption, fill = aware_movement_f))+
geom_violin()+
geom_jitter()+
scale_fill_brewer(palette = "Dark2")+
stat_summary(fun.data=mean_sdl, mult = 1,
geom = "pointrange", color = "black")+
facet_grid(cols = vars(piece), rows = vars(group))+
theme_minimal()+
theme(legend.position = "bottom")+
theme(axis.text.x = element_blank())+
theme(axis.title.x = element_blank())+
labs(title = "Aware of Own Movement", fill = "Aware Movement")## Warning: Ignoring unknown parameters: mult## Warning: Removed 16 rows containing non-finite values (stat_ydensity).## Warning: Groups with fewer than two data points have been dropped.
## Groups with fewer than two data points have been dropped.## Warning: Removed 16 rows containing non-finite values (stat_summary).## Warning: Removed 16 rows containing missing values (geom_point).## Warning: Removed 1 rows containing missing values (geom_segment).
## Removed 1 rows containing missing values (geom_segment).
Aware of other’s movement
df_move_abs%>%
filter(! aware_others_moving_f==0)%>% filter(! is.na(aware_others_moving_f))%>%
ggplot(aes(x= aware_others_moving_f, y = Absorption, fill = aware_others_moving_f))+
geom_violin()+
geom_jitter()+
scale_fill_brewer(palette = "Dark2")+
stat_summary(fun.data=mean_sdl, mult = 1,
geom = "pointrange", color = "black")+
facet_grid(cols = vars(piece), rows = vars(group))+
theme_minimal()+
theme(legend.position = "bottom")+
theme(axis.text.x = element_blank())+
theme(axis.title.x = element_blank())+
labs(title = "Aware of Other's Movement", fill = "Aware Other's Movement")## Warning: Ignoring unknown parameters: mult## Warning: Removed 11 rows containing non-finite values (stat_ydensity).## Warning: Groups with fewer than two data points have been dropped.
## Groups with fewer than two data points have been dropped.
## Groups with fewer than two data points have been dropped.## Warning: Removed 11 rows containing non-finite values (stat_summary).## Warning: Removed 11 rows containing missing values (geom_point).## Warning: Removed 1 rows containing missing values (geom_segment).
## Removed 1 rows containing missing values (geom_segment).
## Removed 1 rows containing missing values (geom_segment).
Test: Rmcorr
Finn suggests I should run a rank U test to examine whether there were differing absorption levels across different response options. There should be a categorical distinction between not aware and aware.
Absorption and Awareness are repeated measures therefore a Mann-Whitney U test is actually not what we need.
Is there a relation between awareness and absorption? Repeated measures correlation with Spearman would be able to assess this. I don’t think that rmcorr can be changed to be used with spearman but I can just try to see if there is an observed correlation
# aware body: NS
rmc<-rmcorr(Pt_ID, aware_body_n,Absorption, df_move_abs)## Warning in rmcorr(Pt_ID, aware_body_n, Absorption, df_move_abs): 'Pt_ID' coerced
## into a factorrmc##
## Repeated measures correlation
##
## r
## -0.1024136
##
## degrees of freedom
## 224
##
## p-value
## 0.1247555
##
## 95% confidence interval
## -0.2304033 0.02905937plot(rmc, overall = TRUE)
# aware movement: SIG
rmc<-rmcorr(Pt_ID, aware_movement_n,Absorption, df_move_abs)## Warning in rmcorr(Pt_ID, aware_movement_n, Absorption, df_move_abs): 'Pt_ID'
## coerced into a factorrmc##
## Repeated measures correlation
##
## r
## 0.1453021
##
## degrees of freedom
## 223
##
## p-value
## 0.02933397
##
## 95% confidence interval
## 0.01419614 0.2714964plot(rmc, overall = TRUE)
# aware others movement: SIG
rmc<-rmcorr(Pt_ID, aware_others_moving_n,Absorption, df_move_abs)## Warning in rmcorr(Pt_ID, aware_others_moving_n, Absorption, df_move_abs):
## 'Pt_ID' coerced into a factorrmc##
## Repeated measures correlation
##
## r
## 0.2162875
##
## degrees of freedom
## 220
##
## p-value
## 0.00118324
##
## 95% confidence interval
## 0.08649043 0.3388645plot(rmc, overall = TRUE)
Test: LME
One resource suggests that for ordinal predictors in lme, you can either choose to treat it as a factor (categorical) or numeric (continuous). https://stats.stackexchange.com/questions/230802/including-ordinal-independent-variables-in-a-linear-mixed-effects-model-using-t
Here is a description of how to interpret output of R and lme based on the data type of the predictor variables: https://stackoverflow.com/questions/25735636/interpretation-of-ordered-and-non-ordered-factors-vs-numerical-predictors-in-m/25736023#25736023
Modelling the random effects structure appropriately is important. It could be modeled with a random intercept or a ranodm intercept and slope. The only way to model with a random slope is to treat the predictor variable as numeric.
Testing with mixed ANOVA is not possible because there are some design cells that are empty (cases where less than 3 people reported the same awareness level). Testing with ANCOVA does not allow for a repeated measures design. Including a random slope in addition to the random intercept may prevent the model from converging.
Is a random slope of participant necessary?
aov.dat<-df_move_abs%>%
filter(! is.na(aware_body))%>%
filter(! is.na(aware_movement))%>%
filter(! is.na(aware_others_moving))%>%
drop_na()Check assumptions
Aware body: assumptions satisfied. One outlier, no extreme
Aware Movement: ADQ030 was flagged as an extreme outlier. ADQ030 = d051. Check the folk aware_movement and absorption survey responses to make sure they were entered into the spreadsheet correctly. The data was all entered correctly. The participant reported being very absorbed in the music and moving less than normal during pieces in which everyone else reported more movement than normal.
The assumptions may be a bit violated for these tests but the figure doesn’t indicate differences by report and the test did not detect significant differences.
Aware others movement: There is just one individual in one of the groups so it is unlikely that this is how we should do the test, however the figure does not really indicate differences between groups and the test did not report any significant differences.
check_assumptions_f<-aov.dat%>%select(Pt_ID, piece, group, aware_body_f, aware_movement_f, aware_others_moving_f,Absorption)
# Outliers
check_assumptions_f%>%group_by(piece, group)%>%identify_outliers(Absorption) ## # A tibble: 1 × 9
## piece group Pt_ID aware_body_f aware_movement_f aware_others_mo… Absorption
## <fct> <fct> <chr> <fct> <fct> <fct> <dbl>
## 1 Schnitt… Live ADQ0… Intermitten… Yes and I moved… Yes and they mo… -2.79
## # … with 2 more variables: is.outlier <lgl>, is.extreme <lgl>check_assumptions_f%>%group_by(piece, aware_body_f)%>%identify_outliers(Absorption)## # A tibble: 1 × 9
## piece aware_body_f Pt_ID group aware_movement_f aware_others_mo… Absorption
## <fct> <fct> <chr> <fct> <fct> <fct> <dbl>
## 1 Folk Continuously BEQ098 Virtual Yes and I moved… Not aware of ot… -2.66
## # … with 2 more variables: is.outlier <lgl>, is.extreme <lgl>check_assumptions_f%>%group_by(piece, aware_movement_f)%>%identify_outliers(Absorption)## # A tibble: 6 × 9
## piece aware_movement_f Pt_ID group aware_body_f aware_others_mo… Absorption
## <fct> <fct> <chr> <fct> <fct> <fct> <dbl>
## 1 Beethov… Yes and I moved… BDQ0… Virt… Rarely Not aware of ot… -2.61
## 2 Folk Yes and I moved… ADQ0… Live Intermitten… Not aware of ot… 1.49
## 3 Folk Yes and I moved… ADQ0… Live Intermitten… Yes and they mo… 0.365
## 4 Folk Yes and I moved… BEQ0… Virt… Continuously Not aware of ot… -2.66
## 5 Folk Yes and I moved… ADQ0… Live Rarely Yes and they mo… -1.60
## 6 Folk Yes and I moved… BEQ1… Virt… Rarely Not aware of ot… -1.02
## # … with 2 more variables: is.outlier <lgl>, is.extreme <lgl>check_assumptions_f%>%group_by(piece, aware_others_moving_f)%>%identify_outliers(Absorption)## # A tibble: 3 × 9
## piece aware_others_mo… Pt_ID group aware_body_f aware_movement_f Absorption
## <fct> <fct> <chr> <fct> <fct> <fct> <dbl>
## 1 Schnitt… Yes and they mo… ADQ0… Live Rarely Yes and I moved… -2.29
## 2 Schnitt… Yes and they mo… ADQ0… Live Intermitten… Yes and I moved… -2.79
## 3 Folk Yes and they mo… ADQ0… Live Intermitten… Yes and I moved… -1.36
## # … with 2 more variables: is.outlier <lgl>, is.extreme <lgl># Normality
aov.dat%>%group_by(piece, group)%>%shapiro_test(Absorption) # Normality assumption not met for Folk x continuously## # A tibble: 6 × 5
## group piece variable statistic p
## <fct> <fct> <chr> <dbl> <dbl>
## 1 Live Beethoven Absorption 0.976 0.109
## 2 Virtual Beethoven Absorption 0.981 0.792
## 3 Live Schnittke Absorption 0.974 0.0752
## 4 Virtual Schnittke Absorption 0.972 0.647
## 5 Live Folk Absorption 0.954 0.00388
## 6 Virtual Folk Absorption 0.951 0.198aov.dat%>%group_by(piece, aware_body_f)%>%shapiro_test(Absorption) # ## # A tibble: 12 × 5
## piece aware_body_f variable statistic p
## <fct> <fct> <chr> <dbl> <dbl>
## 1 Beethoven Not at all Absorption 0.911 0.471
## 2 Beethoven Rarely Absorption 0.969 0.563
## 3 Beethoven Intermittently Absorption 0.979 0.314
## 4 Beethoven Continuously Absorption 0.957 0.515
## 5 Schnittke Not at all Absorption 0.928 0.429
## 6 Schnittke Rarely Absorption 0.965 0.230
## 7 Schnittke Intermittently Absorption 0.990 0.916
## 8 Schnittke Continuously Absorption 0.945 0.582
## 9 Folk Not at all Absorption 0.861 0.193
## 10 Folk Rarely Absorption 0.953 0.165
## 11 Folk Intermittently Absorption 0.968 0.143
## 12 Folk Continuously Absorption 0.861 0.00650aov.dat%>%group_by(piece, aware_movement_f)%>%shapiro_test(Absorption) # ## # A tibble: 12 × 5
## piece aware_movement_f variable statistic p
## <fct> <fct> <chr> <dbl> <dbl>
## 1 Beethoven Not aware of movement Absorption 0.934 0.231
## 2 Beethoven Yes and I moved less than usual Absorption 0.950 0.0636
## 3 Beethoven Yes and I moved a normal amount Absorption 0.989 0.886
## 4 Beethoven Yes and I moved more than usual Absorption 0.800 0.0813
## 5 Schnittke Not aware of movement Absorption 0.963 0.579
## 6 Schnittke Yes and I moved less than usual Absorption 0.970 0.382
## 7 Schnittke Yes and I moved a normal amount Absorption 0.983 0.756
## 8 Schnittke Yes and I moved more than usual Absorption 0.969 0.865
## 9 Folk Not aware of movement Absorption 0.926 0.267
## 10 Folk Yes and I moved less than usual Absorption 0.736 0.00372
## 11 Folk Yes and I moved a normal amount Absorption 0.957 0.0745
## 12 Folk Yes and I moved more than usual Absorption 0.947 0.0423#aov.dat%>%group_by(piece, aware_others_moving)%>%shapiro_test(Absorption) # One group has only one person therefore this test wouldn't run
# at high sample sizes normality is easily violated therefore a qqplot could be a better test
ggqqplot(aov.dat, "Absorption", ggtheme = theme_bw()) +
facet_grid(piece ~ aware_body_f) 
ggqqplot(aov.dat, "Absorption", ggtheme = theme_bw()) +
facet_grid(piece ~ aware_movement_f) 
ggqqplot(aov.dat, "Absorption", ggtheme = theme_bw()) +
facet_grid(piece ~ aware_others_moving_f) ## geom_path: Each group consists of only one observation. Do you need to adjust
## the group aesthetic?
ggqqplot(aov.dat, "Absorption", ggtheme = theme_bw()) +
facet_grid(aware_body_f ~ group) 
ggqqplot(aov.dat, "Absorption", ggtheme = theme_bw()) +
facet_grid(aware_movement_f ~ group) 
ggqqplot(aov.dat, "Absorption", ggtheme = theme_bw()) +
facet_grid(aware_others_moving_f ~ group) 
leveneTest(Absorption ~ group, data = aov.dat) # not violated.## Levene's Test for Homogeneity of Variance (center = median)
## Df F value Pr(>F)
## group 1 9e-04 0.9755
## 352Aware Body
Random intercept
Awareness body: There was a main effect of awareness if body (X2(3)=9.00, p = .029).
baseline<-lmer(Absorption ~ 1 + (1|Pt_ID), data = aov.dat, REML= FALSE)
pieceM<-lmer(Absorption ~ piece + (1|Pt_ID), data = aov.dat, REML= FALSE)
groupM<-lmer(Absorption ~ piece + group + (1|Pt_ID), data = aov.dat, REML= FALSE)
movementM<-lmer(Absorption ~ piece + group + aware_body_f + (1|Pt_ID), data = aov.dat, REML= FALSE)
movement_groupM<-lmer(Absorption ~ piece + group * aware_body_f + (1|Pt_ID), data = aov.dat, REML= FALSE)
movement_pieceM<-lmer(Absorption ~ group + piece * aware_body_f + (1|Pt_ID), data = aov.dat, REML= FALSE)
anova(baseline, pieceM, groupM, movementM, movement_groupM) # main effect of awareness of body## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## pieceM: Absorption ~ piece + (1 | Pt_ID)
## groupM: Absorption ~ piece + group + (1 | Pt_ID)
## movementM: Absorption ~ piece + group + aware_body_f + (1 | Pt_ID)
## movement_groupM: Absorption ~ piece + group * aware_body_f + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 950.65 962.25 -472.32 944.65
## pieceM 5 935.61 954.96 -462.81 925.61 19.0346 2 7.357e-05 ***
## groupM 6 929.71 952.93 -458.86 917.71 7.8992 1 0.004946 **
## movementM 9 926.72 961.54 -454.36 908.72 8.9967 3 0.029335 *
## movement_groupM 12 930.34 976.77 -453.17 906.34 2.3809 3 0.497204
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1anova(baseline, pieceM, groupM, movementM, movement_pieceM) # trending interaction between awareness of body and piece## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## pieceM: Absorption ~ piece + (1 | Pt_ID)
## groupM: Absorption ~ piece + group + (1 | Pt_ID)
## movementM: Absorption ~ piece + group + aware_body_f + (1 | Pt_ID)
## movement_pieceM: Absorption ~ group + piece * aware_body_f + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 950.65 962.25 -472.32 944.65
## pieceM 5 935.61 954.96 -462.81 925.61 19.0346 2 7.357e-05 ***
## groupM 6 929.71 952.93 -458.86 917.71 7.8992 1 0.004946 **
## movementM 9 926.72 961.54 -454.36 908.72 8.9967 3 0.029335 *
## movement_pieceM 15 927.75 985.79 -448.88 897.75 10.9660 6 0.089432 .
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1summary(movementM)## Linear mixed model fit by maximum likelihood ['lmerMod']
## Formula: Absorption ~ piece + group + aware_body_f + (1 | Pt_ID)
## Data: aov.dat
##
## AIC BIC logLik deviance df.resid
## 926.7 961.5 -454.4 908.7 345
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.3172 -0.6050 0.1179 0.6573 1.8483
##
## Random effects:
## Groups Name Variance Std.Dev.
## Pt_ID (Intercept) 0.3599 0.5999
## Residual 0.5174 0.7193
## Number of obs: 354, groups: Pt_ID, 133
##
## Fixed effects:
## Estimate Std. Error t value
## (Intercept) 0.46195 0.21113 2.188
## pieceSchnittke 0.05699 0.09645 0.591
## pieceFolk 0.38587 0.09561 4.036
## groupVirtual -0.41301 0.14400 -2.868
## aware_body_fRarely -0.44606 0.20691 -2.156
## aware_body_fIntermittently -0.60993 0.20683 -2.949
## aware_body_fContinuously -0.51890 0.23623 -2.197
##
## Correlation of Fixed Effects:
## (Intr) pcSchn picFlk grpVrt awr__R awr__I
## piecSchnttk -0.297
## pieceFolk -0.243 0.498
## groupVirtul -0.185 0.046 0.039
## awr_bdy_fRr -0.816 0.015 -0.011 -0.031
## awr_bdy_fIn -0.877 0.086 0.033 -0.023 0.855
## awr_bdy_fCn -0.769 0.113 0.004 -0.028 0.732 0.787#emmip(movement_pieceM, aware_body_f ~ piece) # visualize the trending interaction
movementM.emm.ab<-emmeans(movementM, "aware_body_f") #
pairs(movementM.emm.ab)## contrast estimate SE df t.ratio p.value
## Not at all - Rarely 0.4461 0.210 341 2.126 0.1469
## Not at all - Intermittently 0.6099 0.210 356 2.906 0.0202
## Not at all - Continuously 0.5189 0.240 359 2.164 0.1354
## Rarely - Intermittently 0.1639 0.113 352 1.448 0.4701
## Rarely - Continuously 0.0728 0.167 360 0.436 0.9723
## Intermittently - Continuously -0.0910 0.149 361 -0.609 0.9291
##
## Results are averaged over the levels of: piece, group
## Degrees-of-freedom method: kenward-roger
## P value adjustment: tukey method for comparing a family of 4 estimates# this indicates that the significant difference in awareness of body levels was from people reporting more absorption when they were not aware of their body at all compared to when they were intermittently aware
# if aware body was added as a numeric variable, would this change significance?
movementM_n<-lmer(Absorption ~ piece + group + aware_body_n + (1|Pt_ID), data = aov.dat, REML= FALSE)
movement_groupM_n<-lmer(Absorption ~ piece + group * aware_body_n + (1|Pt_ID), data = aov.dat, REML= FALSE)
movement_pieceM_n<-lmer(Absorption ~ group + piece * aware_body_n + (1|Pt_ID), data = aov.dat, REML= FALSE)
anova(baseline, pieceM, groupM, movementM_n, movement_groupM_n) # movement effect became slightly less significant## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## pieceM: Absorption ~ piece + (1 | Pt_ID)
## groupM: Absorption ~ piece + group + (1 | Pt_ID)
## movementM_n: Absorption ~ piece + group + aware_body_n + (1 | Pt_ID)
## movement_groupM_n: Absorption ~ piece + group * aware_body_n + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 950.65 962.25 -472.32 944.65
## pieceM 5 935.61 954.96 -462.81 925.61 19.0346 2 7.357e-05 ***
## groupM 6 929.71 952.93 -458.86 917.71 7.8992 1 0.004946 **
## movementM_n 7 927.19 954.28 -456.60 913.19 4.5187 1 0.033527 *
## movement_groupM_n 8 928.93 959.89 -456.47 912.93 0.2599 1 0.610185
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1anova(baseline, pieceM, groupM, movementM_n, movement_pieceM_n) # interaction became slightly more sig, but still only trending## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## pieceM: Absorption ~ piece + (1 | Pt_ID)
## groupM: Absorption ~ piece + group + (1 | Pt_ID)
## movementM_n: Absorption ~ piece + group + aware_body_n + (1 | Pt_ID)
## movement_pieceM_n: Absorption ~ group + piece * aware_body_n + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 950.65 962.25 -472.32 944.65
## pieceM 5 935.61 954.96 -462.81 925.61 19.0346 2 7.357e-05 ***
## groupM 6 929.71 952.93 -458.86 917.71 7.8992 1 0.004946 **
## movementM_n 7 927.19 954.28 -456.60 913.19 4.5187 1 0.033527 *
## movement_pieceM_n 9 925.93 960.75 -453.96 907.93 5.2644 2 0.071921 .
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1summary(movementM_n)## Linear mixed model fit by maximum likelihood ['lmerMod']
## Formula: Absorption ~ piece + group + aware_body_n + (1 | Pt_ID)
## Data: aov.dat
##
## AIC BIC logLik deviance df.resid
## 927.2 954.3 -456.6 913.2 347
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.3352 -0.5589 0.1235 0.6543 1.7574
##
## Random effects:
## Groups Name Variance Std.Dev.
## Pt_ID (Intercept) 0.3871 0.6222
## Residual 0.5140 0.7169
## Number of obs: 354, groups: Pt_ID, 133
##
## Fixed effects:
## Estimate Std. Error t value
## (Intercept) 0.33773 0.21101 1.601
## pieceSchnittke 0.05355 0.09611 0.557
## pieceFolk 0.39083 0.09509 4.110
## groupVirtual -0.41667 0.14708 -2.833
## aware_body_n -0.14160 0.06639 -2.133
##
## Correlation of Fixed Effects:
## (Intr) pcSchn picFlk grpVrt
## piecSchnttk -0.374
## pieceFolk -0.263 0.497
## groupVirtul -0.203 0.044 0.037
## aware_bdy_n -0.889 0.167 0.041 -0.013Random slope
Repeat with a random slope of participant as well.
Using the factor variable is not possible for specifying random slope.
#baseline<-lmer(Absorption ~ 1 + (1+aware_body_f|Pt_ID), data = aov.dat, REML= FALSE)
# Error: number of observations (=354) <= number of random effects (=532) for term (1 + aware_body_f | Pt_ID); the random-effects parameters and the residual variance (or scale parameter) are probably unidentifiable
# number of random effects has something to do with the number of factor levelsTry with the numeric variables instead.
baseline<-lmer(Absorption ~ 1 + (1+aware_body_n|Pt_ID), data = aov.dat, REML= FALSE)
pieceM<-lmer(Absorption ~ piece + (1+aware_body_n|Pt_ID), data = aov.dat, REML= FALSE)
groupM<-lmer(Absorption ~ piece + group + (1+aware_body_n|Pt_ID), data = aov.dat, REML= FALSE)
movementM<-lmer(Absorption ~ piece + group + aware_body_n + (1+aware_body_n|Pt_ID), data = aov.dat, REML= FALSE) ## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, :
## Model failed to converge with max|grad| = 0.00287675 (tol = 0.002, component 1)# Warning: Model failed to converge with max|grad| = 0.00287675 (tol = 0.002, component 1)
movement_groupM<-lmer(Absorption ~ piece + group * aware_body_n + (1+aware_body_n|Pt_ID), data = aov.dat, REML= FALSE)
movement_pieceM<-lmer(Absorption ~ group + piece * aware_body_n + (1+aware_body_n|Pt_ID), data = aov.dat, REML= FALSE)
anova(baseline, pieceM, groupM, movementM, movement_groupM) # trending effect of movement## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 + aware_body_n | Pt_ID)
## pieceM: Absorption ~ piece + (1 + aware_body_n | Pt_ID)
## groupM: Absorption ~ piece + group + (1 + aware_body_n | Pt_ID)
## movementM: Absorption ~ piece + group + aware_body_n + (1 + aware_body_n | Pt_ID)
## movement_groupM: Absorption ~ piece + group * aware_body_n + (1 + aware_body_n | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 953.78 973.12 -471.89 943.78
## pieceM 7 938.32 965.40 -462.16 924.32 19.4601 2 5.947e-05 ***
## groupM 8 932.57 963.53 -458.29 916.57 7.7451 1 0.005386 **
## movementM 9 931.10 965.93 -456.55 913.10 3.4698 1 0.062499 .
## movement_groupM 10 932.90 971.59 -456.45 912.90 0.2018 1 0.653259
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1anova(baseline, pieceM, groupM, movementM, movement_pieceM) # trending interaction between movement and piece## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 + aware_body_n | Pt_ID)
## pieceM: Absorption ~ piece + (1 + aware_body_n | Pt_ID)
## groupM: Absorption ~ piece + group + (1 + aware_body_n | Pt_ID)
## movementM: Absorption ~ piece + group + aware_body_n + (1 + aware_body_n | Pt_ID)
## movement_pieceM: Absorption ~ group + piece * aware_body_n + (1 + aware_body_n | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 953.78 973.12 -471.89 943.78
## pieceM 7 938.32 965.40 -462.16 924.32 19.4601 2 5.947e-05 ***
## groupM 8 932.57 963.53 -458.29 916.57 7.7451 1 0.005386 **
## movementM 9 931.10 965.93 -456.55 913.10 3.4698 1 0.062499 .
## movement_pieceM 11 929.45 972.01 -453.73 907.45 5.6511 2 0.059277 .
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1summary(movementM)## Linear mixed model fit by maximum likelihood ['lmerMod']
## Formula: Absorption ~ piece + group + aware_body_n + (1 + aware_body_n |
## Pt_ID)
## Data: aov.dat
##
## AIC BIC logLik deviance df.resid
## 931.1 965.9 -456.6 913.1 345
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.2398 -0.5634 0.1227 0.6404 1.7731
##
## Random effects:
## Groups Name Variance Std.Dev. Corr
## Pt_ID (Intercept) 0.5672 0.7531
## aware_body_n 0.0259 0.1609 -0.58
## Residual 0.5078 0.7126
## Number of obs: 354, groups: Pt_ID, 133
##
## Fixed effects:
## Estimate Std. Error t value
## (Intercept) 0.32681 0.21723 1.504
## pieceSchnittke 0.05309 0.09602 0.553
## pieceFolk 0.39035 0.09540 4.092
## groupVirtual -0.41455 0.14658 -2.828
## aware_body_n -0.13924 0.06875 -2.025
##
## Correlation of Fixed Effects:
## (Intr) pcSchn picFlk grpVrt
## piecSchnttk -0.366
## pieceFolk -0.264 0.497
## groupVirtul -0.198 0.045 0.039
## aware_bdy_n -0.896 0.165 0.049 -0.011
## optimizer (nloptwrap) convergence code: 0 (OK)
## Model failed to converge with max|grad| = 0.00287675 (tol = 0.002, component 1)The model on awareness of body did not converge with the random slope of participant. This is just a warning though and I need to check these pages to understand if it is real or a false warning: https://rstudio-pubs-static.s3.amazonaws.com/33653_57fc7b8e5d484c909b615d8633c01d51.html Convergence section in the pdf: https://cran.r-project.org/web/packages/lme4/lme4.pdf
Awareness of movement
Random intercept
There was a significant main effect of aware of movement on absorption, X2(3) = 9.61, p = .022. this effect was not still present when including main effects of piece and group.
There was no effect of awareness of movement on absorption when accounting for the influence of piece and group, X2(1)=.38, p = .54.
baseline<-lmer(Absorption ~ 1 + (1|Pt_ID), data = aov.dat, REML= FALSE)
# factor option - NS
pieceM<-lmer(Absorption ~ piece + (1|Pt_ID), data = aov.dat, REML= FALSE)
groupM<-lmer(Absorption ~ piece + group + (1|Pt_ID), data = aov.dat, REML= FALSE)
movementM<-lmer(Absorption ~ piece + group + aware_movement_f + (1|Pt_ID), data = aov.dat, REML= FALSE) # NS
movement_groupM<-lmer(Absorption ~ piece + group*aware_movement_f + (1|Pt_ID), data = aov.dat, REML= FALSE) #NS
movement_pieceM<-lmer(Absorption ~ group + piece*aware_movement_f + (1|Pt_ID), data = aov.dat, REML= FALSE) #NS
anova(baseline, pieceM, groupM, movementM, movement_groupM) # aware movement is not significant with a random intercept## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## pieceM: Absorption ~ piece + (1 | Pt_ID)
## groupM: Absorption ~ piece + group + (1 | Pt_ID)
## movementM: Absorption ~ piece + group + aware_movement_f + (1 | Pt_ID)
## movement_groupM: Absorption ~ piece + group * aware_movement_f + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 950.65 962.25 -472.32 944.65
## pieceM 5 935.61 954.96 -462.81 925.61 19.0346 2 7.357e-05 ***
## groupM 6 929.71 952.93 -458.86 917.71 7.8992 1 0.004946 **
## movementM 9 932.84 967.67 -457.42 914.84 2.8690 3 0.412264
## movement_groupM 12 936.67 983.10 -456.34 912.67 2.1704 3 0.537798
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1anova(baseline, pieceM, groupM, movementM, movement_pieceM) # aware movement is not significant with a random intercept## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## pieceM: Absorption ~ piece + (1 | Pt_ID)
## groupM: Absorption ~ piece + group + (1 | Pt_ID)
## movementM: Absorption ~ piece + group + aware_movement_f + (1 | Pt_ID)
## movement_pieceM: Absorption ~ group + piece * aware_movement_f + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 950.65 962.25 -472.32 944.65
## pieceM 5 935.61 954.96 -462.81 925.61 19.0346 2 7.357e-05 ***
## groupM 6 929.71 952.93 -458.86 917.71 7.8992 1 0.004946 **
## movementM 9 932.84 967.67 -457.42 914.84 2.8690 3 0.412264
## movement_pieceM 15 935.23 993.27 -452.62 905.23 9.6113 6 0.142005
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1# numeric - NS
movementM<-lmer(Absorption ~ piece + group + aware_movement_n + (1|Pt_ID), data = aov.dat, REML= FALSE) # NS
movement_groupM<-lmer(Absorption ~ piece + group*aware_movement_n + (1|Pt_ID), data = aov.dat, REML= FALSE) #NS
movement_pieceM<-lmer(Absorption ~ group + piece*aware_movement_n + (1|Pt_ID), data = aov.dat, REML= FALSE) #NS
anova(baseline, pieceM, groupM, movementM, movement_groupM) # aware movement is not significant with a random intercept## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## pieceM: Absorption ~ piece + (1 | Pt_ID)
## groupM: Absorption ~ piece + group + (1 | Pt_ID)
## movementM: Absorption ~ piece + group + aware_movement_n + (1 | Pt_ID)
## movement_groupM: Absorption ~ piece + group * aware_movement_n + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 950.65 962.25 -472.32 944.65
## pieceM 5 935.61 954.96 -462.81 925.61 19.0346 2 7.357e-05 ***
## groupM 6 929.71 952.93 -458.86 917.71 7.8992 1 0.004946 **
## movementM 7 931.33 958.42 -458.67 917.33 0.3819 1 0.536589
## movement_groupM 8 932.93 963.88 -458.46 916.93 0.4045 1 0.524778
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1anova(baseline, pieceM, groupM, movementM, movement_pieceM) # aware movement is not significant with a random intercept## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## pieceM: Absorption ~ piece + (1 | Pt_ID)
## groupM: Absorption ~ piece + group + (1 | Pt_ID)
## movementM: Absorption ~ piece + group + aware_movement_n + (1 | Pt_ID)
## movement_pieceM: Absorption ~ group + piece * aware_movement_n + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 950.65 962.25 -472.32 944.65
## pieceM 5 935.61 954.96 -462.81 925.61 19.0346 2 7.357e-05 ***
## groupM 6 929.71 952.93 -458.86 917.71 7.8992 1 0.004946 **
## movementM 7 931.33 958.42 -458.67 917.33 0.3819 1 0.536589
## movement_pieceM 9 931.05 965.88 -456.53 913.05 4.2776 2 0.117794
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1# Interactions were not significant eitherRandom slope
Try with a random slope of participant in addition to a random intercept
There is no effect of awareness of movement on absorption.
# try numeric
baseline<-lmer(Absorption ~ 1 + (1+aware_movement_n|Pt_ID), data = aov.dat, REML= FALSE)
pieceM<-lmer(Absorption ~ piece + (1+aware_movement_n|Pt_ID), data = aov.dat, REML= FALSE)
groupM<-lmer(Absorption ~ piece + group + (1+aware_movement_n|Pt_ID), data = aov.dat, REML= FALSE)
movementM<-lmer(Absorption ~ piece + group + aware_movement_n + (1+aware_movement_n|Pt_ID), data = aov.dat, REML= FALSE) # no warning (unlike aware body) # NS
movement_groupM<-lmer(Absorption ~ piece + group*aware_movement_n + (1+aware_movement_n|Pt_ID), data = aov.dat, REML= FALSE) #NS
movement_pieceM<-lmer(Absorption ~ group + piece*aware_movement_n + (1+aware_movement_n|Pt_ID), data = aov.dat, REML= FALSE) #NS
anova(baseline, pieceM, groupM, movementM, movement_groupM) # aware movement is not significant with a random slope.## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 + aware_movement_n | Pt_ID)
## pieceM: Absorption ~ piece + (1 + aware_movement_n | Pt_ID)
## groupM: Absorption ~ piece + group + (1 + aware_movement_n | Pt_ID)
## movementM: Absorption ~ piece + group + aware_movement_n + (1 + aware_movement_n | Pt_ID)
## movement_groupM: Absorption ~ piece + group * aware_movement_n + (1 + aware_movement_n | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 949.94 969.29 -469.97 939.94
## pieceM 7 933.95 961.03 -459.97 919.95 19.9949 2 4.552e-05 ***
## groupM 8 928.38 959.33 -456.19 912.38 7.5696 1 0.005936 **
## movementM 9 929.69 964.51 -455.85 911.69 0.6901 1 0.406133
## movement_groupM 10 931.57 970.26 -455.78 911.57 0.1237 1 0.725023
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1anova(baseline, pieceM, groupM, movementM, movement_pieceM) # aware movement is not significant with a random slope.## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 + aware_movement_n | Pt_ID)
## pieceM: Absorption ~ piece + (1 + aware_movement_n | Pt_ID)
## groupM: Absorption ~ piece + group + (1 + aware_movement_n | Pt_ID)
## movementM: Absorption ~ piece + group + aware_movement_n + (1 + aware_movement_n | Pt_ID)
## movement_pieceM: Absorption ~ group + piece * aware_movement_n + (1 + aware_movement_n | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 949.94 969.29 -469.97 939.94
## pieceM 7 933.95 961.03 -459.97 919.95 19.9949 2 4.552e-05 ***
## groupM 8 928.38 959.33 -456.19 912.38 7.5696 1 0.005936 **
## movementM 9 929.69 964.51 -455.85 911.69 0.6901 1 0.406133
## movement_pieceM 11 929.31 971.87 -453.66 907.31 4.3794 2 0.111952
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1Awareness of others’ movement
Random intercept
baseline<-lmer(Absorption ~ 1 + (1|Pt_ID), data = aov.dat, REML= FALSE)
# factor
# if aware others moving was added after piece and group, would it be significant? Yes, but less so: X2(3) = 8.1, p = .044
pieceM<-lmer(Absorption ~ piece + (1|Pt_ID), data = aov.dat, REML= FALSE)
groupM<-lmer(Absorption ~ piece + group + (1|Pt_ID), data = aov.dat, REML= FALSE)
movementM<-lmer(Absorption ~ piece + group + aware_others_moving_f + (1|Pt_ID), data = aov.dat, REML= FALSE) # sig
movement_groupM<-lmer(Absorption ~ piece + group*aware_others_moving_f + (1|Pt_ID), data = aov.dat, REML= FALSE) # NS
movement_pieceM<-lmer(Absorption ~ group + piece*aware_others_moving_f + (1|Pt_ID), data = aov.dat, REML= FALSE) # SIG
anova(baseline, pieceM, groupM, movementM, movement_groupM) # then yes, but less sig## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## pieceM: Absorption ~ piece + (1 | Pt_ID)
## groupM: Absorption ~ piece + group + (1 | Pt_ID)
## movementM: Absorption ~ piece + group + aware_others_moving_f + (1 | Pt_ID)
## movement_groupM: Absorption ~ piece + group * aware_others_moving_f + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 950.65 962.25 -472.32 944.65
## pieceM 5 935.61 954.96 -462.81 925.61 19.0346 2 7.357e-05 ***
## groupM 6 929.71 952.93 -458.86 917.71 7.8992 1 0.004946 **
## movementM 9 927.61 962.43 -454.80 909.61 8.1046 3 0.043899 *
## movement_groupM 12 928.30 974.73 -452.15 904.30 5.3103 3 0.150433
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1anova(baseline, pieceM, groupM, movementM, movement_pieceM) # and interaction between awareness of others motion and piece effects on absorption## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## pieceM: Absorption ~ piece + (1 | Pt_ID)
## groupM: Absorption ~ piece + group + (1 | Pt_ID)
## movementM: Absorption ~ piece + group + aware_others_moving_f + (1 | Pt_ID)
## movement_pieceM: Absorption ~ group + piece * aware_others_moving_f + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 950.65 962.25 -472.32 944.65
## pieceM 5 935.61 954.96 -462.81 925.61 19.0346 2 7.357e-05 ***
## groupM 6 929.71 952.93 -458.86 917.71 7.8992 1 0.004946 **
## movementM 9 927.61 962.43 -454.80 909.61 8.1046 3 0.043899 *
## movement_pieceM 15 923.52 981.56 -446.76 893.52 16.0883 6 0.013288 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1# numeric
movementM<-lmer(Absorption ~ piece + group + aware_others_moving_n + (1|Pt_ID), data = aov.dat, REML= FALSE) # NS
movement_groupM<-lmer(Absorption ~ piece + group*aware_others_moving_n + (1|Pt_ID), data = aov.dat, REML= FALSE) # NS
movement_pieceM<-lmer(Absorption ~ group + piece*aware_others_moving_n + (1|Pt_ID), data = aov.dat, REML= FALSE) # SIG
anova(baseline, pieceM, groupM, movementM, movement_groupM) # numeric: no sig effet of awareness of others motion## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## pieceM: Absorption ~ piece + (1 | Pt_ID)
## groupM: Absorption ~ piece + group + (1 | Pt_ID)
## movementM: Absorption ~ piece + group + aware_others_moving_n + (1 | Pt_ID)
## movement_groupM: Absorption ~ piece + group * aware_others_moving_n + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 950.65 962.25 -472.32 944.65
## pieceM 5 935.61 954.96 -462.81 925.61 19.0346 2 7.357e-05 ***
## groupM 6 929.71 952.93 -458.86 917.71 7.8992 1 0.004946 **
## movementM 7 931.55 958.63 -458.77 917.55 0.1631 1 0.686340
## movement_groupM 8 932.07 963.02 -458.03 916.07 1.4827 1 0.223346
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1anova(baseline, pieceM, groupM, movementM, movement_pieceM) # numeric: sig interaction between aware others and piece on absorption## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 | Pt_ID)
## pieceM: Absorption ~ piece + (1 | Pt_ID)
## groupM: Absorption ~ piece + group + (1 | Pt_ID)
## movementM: Absorption ~ piece + group + aware_others_moving_n + (1 | Pt_ID)
## movement_pieceM: Absorption ~ group + piece * aware_others_moving_n + (1 | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 3 950.65 962.25 -472.32 944.65
## pieceM 5 935.61 954.96 -462.81 925.61 19.0346 2 7.357e-05 ***
## groupM 6 929.71 952.93 -458.86 917.71 7.8992 1 0.004946 **
## movementM 7 931.55 958.63 -458.77 917.55 0.1631 1 0.686340
## movement_pieceM 9 920.04 954.86 -451.02 902.04 15.5130 2 0.000428 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1Post-hoc testing
# factor model
movement_pieceM<-lmer(Absorption ~ group + piece*aware_others_moving_f + (1|Pt_ID), data = aov.dat, REML= FALSE) # SIG
summary(movement_pieceM)## Linear mixed model fit by maximum likelihood ['lmerMod']
## Formula: Absorption ~ group + piece * aware_others_moving_f + (1 | Pt_ID)
## Data: aov.dat
##
## AIC BIC logLik deviance df.resid
## 923.5 981.6 -446.8 893.5 339
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -2.98945 -0.60888 0.09361 0.66141 1.86980
##
## Random effects:
## Groups Name Variance Std.Dev.
## Pt_ID (Intercept) 0.3752 0.6125
## Residual 0.4824 0.6945
## Number of obs: 354, groups: Pt_ID, 133
##
## Fixed effects:
## Estimate
## (Intercept) -0.03993
## groupVirtual -0.41040
## pieceSchnittke 0.18197
## pieceFolk 0.14342
## aware_others_moving_fYes and they moved less than usual 0.10735
## aware_others_moving_fYes and they moved a normal amount -0.54598
## aware_others_moving_fYes and they moved more than usual 0.48647
## pieceSchnittke:aware_others_moving_fYes and they moved less than usual -0.15814
## pieceFolk:aware_others_moving_fYes and they moved less than usual 0.30513
## pieceSchnittke:aware_others_moving_fYes and they moved a normal amount -0.20938
## pieceFolk:aware_others_moving_fYes and they moved a normal amount 0.87859
## pieceSchnittke:aware_others_moving_fYes and they moved more than usual -0.74002
## pieceFolk:aware_others_moving_fYes and they moved more than usual -0.03281
## Std. Error
## (Intercept) 0.10546
## groupVirtual 0.14871
## pieceSchnittke 0.10923
## pieceFolk 0.12690
## aware_others_moving_fYes and they moved less than usual 0.22136
## aware_others_moving_fYes and they moved a normal amount 0.28242
## aware_others_moving_fYes and they moved more than usual 0.80342
## pieceSchnittke:aware_others_moving_fYes and they moved less than usual 0.30120
## pieceFolk:aware_others_moving_fYes and they moved less than usual 0.35073
## pieceSchnittke:aware_others_moving_fYes and they moved a normal amount 0.34519
## pieceFolk:aware_others_moving_fYes and they moved a normal amount 0.34088
## pieceSchnittke:aware_others_moving_fYes and they moved more than usual 0.82279
## pieceFolk:aware_others_moving_fYes and they moved more than usual 0.81237
## t value
## (Intercept) -0.379
## groupVirtual -2.760
## pieceSchnittke 1.666
## pieceFolk 1.130
## aware_others_moving_fYes and they moved less than usual 0.485
## aware_others_moving_fYes and they moved a normal amount -1.933
## aware_others_moving_fYes and they moved more than usual 0.606
## pieceSchnittke:aware_others_moving_fYes and they moved less than usual -0.525
## pieceFolk:aware_others_moving_fYes and they moved less than usual 0.870
## pieceSchnittke:aware_others_moving_fYes and they moved a normal amount -0.607
## pieceFolk:aware_others_moving_fYes and they moved a normal amount 2.577
## pieceSchnittke:aware_others_moving_fYes and they moved more than usual -0.899
## pieceFolk:aware_others_moving_fYes and they moved more than usual -0.040##
## Correlation matrix not shown by default, as p = 13 > 12.
## Use print(x, correlation=TRUE) or
## vcov(x) if you need it# visualize the interaction
emmip(movement_pieceM, aware_others_moving_f ~ piece)
movement_pieceM.emm.aom<-emmeans(movement_pieceM, pairwise ~ aware_others_moving_f|piece) #
movement_pieceM.emm.aom## $emmeans
## piece = Beethoven:
## aware_others_moving_f emmean SE df lower.CL upper.CL
## Not aware of others' movement -0.2451 0.0963 307 -0.4346 -0.0557
## Yes and they moved less than usual -0.1378 0.2170 356 -0.5645 0.2889
## Yes and they moved a normal amount -0.7911 0.2827 333 -1.3472 -0.2351
## Yes and they moved more than usual 0.2413 0.8208 309 -1.3737 1.8564
##
## piece = Schnittke:
## aware_others_moving_f emmean SE df lower.CL upper.CL
## Not aware of others' movement -0.0632 0.1036 330 -0.2670 0.1406
## Yes and they moved less than usual -0.1140 0.2369 348 -0.5799 0.3520
## Yes and they moved a normal amount -0.8185 0.2316 347 -1.2741 -0.3630
## Yes and they moved more than usual -0.3167 0.2811 334 -0.8696 0.2361
##
## piece = Folk:
## aware_others_moving_f emmean SE df lower.CL upper.CL
## Not aware of others' movement -0.1017 0.1215 361 -0.3406 0.1371
## Yes and they moved less than usual 0.3108 0.2985 337 -0.2763 0.8979
## Yes and they moved a normal amount 0.2309 0.2080 348 -0.1782 0.6400
## Yes and they moved more than usual 0.3519 0.1476 366 0.0617 0.6422
##
## Results are averaged over the levels of: group
## Degrees-of-freedom method: kenward-roger
## Confidence level used: 0.95
##
## $contrasts
## piece = Beethoven:
## contrast
## Not aware of others' movement - Yes and they moved less than usual
## Not aware of others' movement - Yes and they moved a normal amount
## Not aware of others' movement - Yes and they moved more than usual
## Yes and they moved less than usual - Yes and they moved a normal amount
## Yes and they moved less than usual - Yes and they moved more than usual
## Yes and they moved a normal amount - Yes and they moved more than usual
## estimate SE df t.ratio p.value
## -0.1073 0.227 328 -0.473 0.9649
## 0.5460 0.289 313 1.887 0.2356
## -0.4865 0.823 306 -0.591 0.9347
## 0.6533 0.341 307 1.914 0.2242
## -0.3791 0.842 305 -0.450 0.9695
## -1.0325 0.861 305 -1.199 0.6282
##
## piece = Schnittke:
## contrast
## Not aware of others' movement - Yes and they moved less than usual
## Not aware of others' movement - Yes and they moved a normal amount
## Not aware of others' movement - Yes and they moved more than usual
## Yes and they moved less than usual - Yes and they moved a normal amount
## Yes and they moved less than usual - Yes and they moved more than usual
## Yes and they moved a normal amount - Yes and they moved more than usual
## estimate SE df t.ratio p.value
## 0.0508 0.248 322 0.205 0.9970
## 0.7554 0.242 320 3.125 0.0104
## 0.2535 0.290 314 0.874 0.8182
## 0.7046 0.317 310 2.226 0.1185
## 0.2028 0.355 309 0.570 0.9408
## -0.5018 0.351 311 -1.429 0.4820
##
## piece = Folk:
## contrast
## Not aware of others' movement - Yes and they moved less than usual
## Not aware of others' movement - Yes and they moved a normal amount
## Not aware of others' movement - Yes and they moved more than usual
## Yes and they moved less than usual - Yes and they moved a normal amount
## Yes and they moved less than usual - Yes and they moved more than usual
## Yes and they moved a normal amount - Yes and they moved more than usual
## estimate SE df t.ratio p.value
## -0.4125 0.316 322 -1.305 0.5606
## -0.3326 0.232 314 -1.435 0.4782
## -0.4537 0.179 313 -2.536 0.0565
## 0.0799 0.352 310 0.227 0.9959
## -0.0412 0.319 310 -0.129 0.9992
## -0.1210 0.239 309 -0.506 0.9576
##
## Results are averaged over the levels of: group
## Degrees-of-freedom method: kenward-roger
## P value adjustment: tukey method for comparing a family of 4 estimatesmovement_pieceM.emm<-emmeans(movement_pieceM, ~ aware_others_moving_f * piece) #
pairs(movement_pieceM.emm, simple = "piece")## aware_others_moving_f = Not aware of others' movement:
## contrast estimate SE df t.ratio p.value
## Beethoven - Schnittke -0.1820 0.112 255 -1.628 0.2356
## Beethoven - Folk -0.1434 0.130 270 -1.104 0.5122
## Schnittke - Folk 0.0385 0.134 269 0.287 0.9557
##
## aware_others_moving_f = Yes and they moved less than usual:
## contrast estimate SE df t.ratio p.value
## Beethoven - Schnittke -0.0238 0.284 266 -0.084 0.9961
## Beethoven - Folk -0.4485 0.333 271 -1.348 0.3699
## Schnittke - Folk -0.4247 0.352 281 -1.207 0.4499
##
## aware_others_moving_f = Yes and they moved a normal amount:
## contrast estimate SE df t.ratio p.value
## Beethoven - Schnittke 0.0274 0.331 276 0.083 0.9962
## Beethoven - Folk -1.0220 0.322 281 -3.169 0.0048
## Schnittke - Folk -1.0494 0.286 291 -3.671 0.0008
##
## aware_others_moving_f = Yes and they moved more than usual:
## contrast estimate SE df t.ratio p.value
## Beethoven - Schnittke 0.5581 0.834 286 0.669 0.7818
## Beethoven - Folk -0.1106 0.821 300 -0.135 0.9900
## Schnittke - Folk -0.6687 0.291 284 -2.301 0.0573
##
## Results are averaged over the levels of: group
## Degrees-of-freedom method: kenward-roger
## P value adjustment: tukey method for comparing a family of 3 estimates# People who reported being aware of others movement and that they moved a normal amount reported higher absorption in the folk than the Schnittke and the Beethoven
pairs(movement_pieceM.emm, simple = "aware_others_moving_f")## piece = Beethoven:
## contrast
## Not aware of others' movement - Yes and they moved less than usual
## Not aware of others' movement - Yes and they moved a normal amount
## Not aware of others' movement - Yes and they moved more than usual
## Yes and they moved less than usual - Yes and they moved a normal amount
## Yes and they moved less than usual - Yes and they moved more than usual
## Yes and they moved a normal amount - Yes and they moved more than usual
## estimate SE df t.ratio p.value
## -0.1073 0.227 328 -0.473 0.9649
## 0.5460 0.289 313 1.887 0.2356
## -0.4865 0.823 306 -0.591 0.9347
## 0.6533 0.341 307 1.914 0.2242
## -0.3791 0.842 305 -0.450 0.9695
## -1.0325 0.861 305 -1.199 0.6282
##
## piece = Schnittke:
## contrast
## Not aware of others' movement - Yes and they moved less than usual
## Not aware of others' movement - Yes and they moved a normal amount
## Not aware of others' movement - Yes and they moved more than usual
## Yes and they moved less than usual - Yes and they moved a normal amount
## Yes and they moved less than usual - Yes and they moved more than usual
## Yes and they moved a normal amount - Yes and they moved more than usual
## estimate SE df t.ratio p.value
## 0.0508 0.248 322 0.205 0.9970
## 0.7554 0.242 320 3.125 0.0104
## 0.2535 0.290 314 0.874 0.8182
## 0.7046 0.317 310 2.226 0.1185
## 0.2028 0.355 309 0.570 0.9408
## -0.5018 0.351 311 -1.429 0.4820
##
## piece = Folk:
## contrast
## Not aware of others' movement - Yes and they moved less than usual
## Not aware of others' movement - Yes and they moved a normal amount
## Not aware of others' movement - Yes and they moved more than usual
## Yes and they moved less than usual - Yes and they moved a normal amount
## Yes and they moved less than usual - Yes and they moved more than usual
## Yes and they moved a normal amount - Yes and they moved more than usual
## estimate SE df t.ratio p.value
## -0.4125 0.316 322 -1.305 0.5606
## -0.3326 0.232 314 -1.435 0.4782
## -0.4537 0.179 313 -2.536 0.0565
## 0.0799 0.352 310 0.227 0.9959
## -0.0412 0.319 310 -0.129 0.9992
## -0.1210 0.239 309 -0.506 0.9576
##
## Results are averaged over the levels of: group
## Degrees-of-freedom method: kenward-roger
## P value adjustment: tukey method for comparing a family of 4 estimates# There was a significant difference in people's reports of awareness and absorption in the Schnittke piece such that people who reported not being aware of others' motion reported more absorption than those who reported they were aware and they moved a normal amount (t(320)=3.125, p = .010)
#check sample sizes
aov.dat%>%group_by(piece, aware_others_moving_f)%>%summarize(n())## Warning in gzfile(file, mode): cannot open compressed file 'C:/Users/Dana/
## AppData/Local/Temp/RtmpSoZMsO\file3fc014f5741d', probable reason 'No such file
## or directory'## `summarise()` has grouped output by 'piece'. You can override using the
## `.groups` argument.## # A tibble: 12 × 3
## # Groups: piece [3]
## piece aware_others_moving_f `n()`
## <fct> <fct> <int>
## 1 Beethoven Not aware of others' movement 95
## 2 Beethoven Yes and they moved less than usual 16
## 3 Beethoven Yes and they moved a normal amount 9
## 4 Beethoven Yes and they moved more than usual 1
## 5 Schnittke Not aware of others' movement 81
## 6 Schnittke Yes and they moved less than usual 13
## 7 Schnittke Yes and they moved a normal amount 14
## 8 Schnittke Yes and they moved more than usual 9
## 9 Folk Not aware of others' movement 53
## 10 Folk Yes and they moved less than usual 8
## 11 Folk Yes and they moved a normal amount 17
## 12 Folk Yes and they moved more than usual 38aov.dat%>%group_by(piece, aware_movement_f)%>%summarize(n())## `summarise()` has grouped output by 'piece'. You can override using the
## `.groups` argument.## # A tibble: 12 × 3
## # Groups: piece [3]
## piece aware_movement_f `n()`
## <fct> <fct> <int>
## 1 Beethoven Not aware of movement 18
## 2 Beethoven Yes and I moved less than usual 42
## 3 Beethoven Yes and I moved a normal amount 56
## 4 Beethoven Yes and I moved more than usual 5
## 5 Schnittke Not aware of movement 21
## 6 Schnittke Yes and I moved less than usual 39
## 7 Schnittke Yes and I moved a normal amount 43
## 8 Schnittke Yes and I moved more than usual 14
## 9 Folk Not aware of movement 14
## 10 Folk Yes and I moved less than usual 9
## 11 Folk Yes and I moved a normal amount 49
## 12 Folk Yes and I moved more than usual 44aov.dat%>%group_by(piece, aware_body_f)%>%summarize(n())## `summarise()` has grouped output by 'piece'. You can override using the
## `.groups` argument.## # A tibble: 12 × 3
## # Groups: piece [3]
## piece aware_body_f `n()`
## <fct> <fct> <int>
## 1 Beethoven Not at all 5
## 2 Beethoven Rarely 28
## 3 Beethoven Intermittently 69
## 4 Beethoven Continuously 19
## 5 Schnittke Not at all 10
## 6 Schnittke Rarely 41
## 7 Schnittke Intermittently 55
## 8 Schnittke Continuously 11
## 9 Folk Not at all 6
## 10 Folk Rarely 33
## 11 Folk Intermittently 56
## 12 Folk Continuously 21Random slope
what about with a random slope
baseline<-lmer(Absorption ~ 1 + (1+aware_others_moving_n|Pt_ID), data = aov.dat, REML= FALSE)
pieceM<-lmer(Absorption ~ piece + (1+aware_others_moving_n|Pt_ID), data = aov.dat, REML= FALSE)
groupM<-lmer(Absorption ~ piece + group + (1+aware_others_moving_n|Pt_ID), data = aov.dat, REML= FALSE)## boundary (singular) fit: see help('isSingular')movementM<-lmer(Absorption ~ piece + group + aware_others_moving_n + (1+aware_others_moving_n|Pt_ID), data = aov.dat, REML= FALSE) # NS # warning on boundary fit is singular## boundary (singular) fit: see help('isSingular')movement_groupM<-lmer(Absorption ~ piece + group*aware_others_moving_n + (1+aware_others_moving_n|Pt_ID), data = aov.dat, REML= FALSE) # NS# warning on boundary fit is singular## boundary (singular) fit: see help('isSingular')movement_pieceM<-lmer(Absorption ~ group + piece*aware_others_moving_n + (1+aware_others_moving_n|Pt_ID), data = aov.dat, REML= FALSE) # significant
anova(baseline, pieceM, groupM, movementM, movement_groupM) # NS## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 + aware_others_moving_n | Pt_ID)
## pieceM: Absorption ~ piece + (1 + aware_others_moving_n | Pt_ID)
## groupM: Absorption ~ piece + group + (1 + aware_others_moving_n | Pt_ID)
## movementM: Absorption ~ piece + group + aware_others_moving_n + (1 + aware_others_moving_n | Pt_ID)
## movement_groupM: Absorption ~ piece + group * aware_others_moving_n + (1 + aware_others_moving_n | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 953.33 972.68 -471.67 943.33
## pieceM 7 938.71 965.79 -462.35 924.71 18.6274 2 9.018e-05 ***
## groupM 8 933.31 964.27 -458.66 917.31 7.3921 1 0.006551 **
## movementM 9 935.14 969.96 -458.57 917.14 0.1776 1 0.673448
## movement_groupM 10 935.76 974.45 -457.88 915.76 1.3767 1 0.240669
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1anova(baseline, pieceM, groupM, movementM, movement_pieceM) # slightly more significant than the random intercept model## Data: aov.dat
## Models:
## baseline: Absorption ~ 1 + (1 + aware_others_moving_n | Pt_ID)
## pieceM: Absorption ~ piece + (1 + aware_others_moving_n | Pt_ID)
## groupM: Absorption ~ piece + group + (1 + aware_others_moving_n | Pt_ID)
## movementM: Absorption ~ piece + group + aware_others_moving_n + (1 + aware_others_moving_n | Pt_ID)
## movement_pieceM: Absorption ~ group + piece * aware_others_moving_n + (1 + aware_others_moving_n | Pt_ID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## baseline 5 953.33 972.68 -471.67 943.33
## pieceM 7 938.71 965.79 -462.35 924.71 18.6274 2 9.018e-05 ***
## groupM 8 933.31 964.27 -458.66 917.31 7.3921 1 0.0065510 **
## movementM 9 935.14 969.96 -458.57 917.14 0.1776 1 0.6734477
## movement_pieceM 11 923.15 965.71 -450.58 901.15 15.9841 2 0.0003381 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1Test: Mixed ANOVA
This approach does not seem to work because of lack of data in some cells.
3-way mixed ANOVA Outcome/Dependent variable= Absorption Repeated measure/within subjects: piece, awareness Between subjects: group
aov.dat %>%
select(Pt_ID,group, piece, aware_body_f, aware_movement_f,aware_others_moving_f, Absorption)%>%
group_by(piece, group,aware_body_f) %>%
identify_outliers(Absorption) # there are no extreme outliers## # A tibble: 5 × 9
## group piece aware_body_f Pt_ID aware_movement_f aware_others_mo… Absorption
## <fct> <fct> <fct> <chr> <fct> <fct> <dbl>
## 1 Virtual Beeth… Intermitten… BEQ0… Yes and I moved… Not aware of ot… 1.17
## 2 Live Schni… Rarely ADQ0… Yes and I moved… Yes and they mo… -2.29
## 3 Virtual Schni… Rarely BEU1… Yes and I moved… Yes and they mo… 1.61
## 4 Live Folk Intermitten… ADQ0… Yes and I moved… Not aware of ot… -1.65
## 5 Virtual Folk Continuously BEQ0… Yes and I moved… Not aware of ot… -2.66
## # … with 2 more variables: is.outlier <lgl>, is.extreme <lgl>aov.dat %>%
select(Pt_ID,group, piece, aware_body_f, aware_movement_f,aware_others_moving_f, Absorption)%>%
group_by(piece, group,aware_movement_f) %>%
identify_outliers(Absorption) # there is one extreme outlier## # A tibble: 5 × 9
## group piece aware_movement_f Pt_ID aware_body_f aware_others_mo… Absorption
## <fct> <fct> <fct> <chr> <fct> <fct> <dbl>
## 1 Virtual Beeth… Yes and I moved… BDQ0… Rarely Not aware of ot… -2.61
## 2 Live Folk Yes and I moved… ADQ0… Intermitten… Not aware of ot… 1.49
## 3 Live Folk Yes and I moved… ADQ0… Rarely Yes and they mo… -1.60
## 4 Live Folk Yes and I moved… ADR0… Intermitten… Yes and they mo… -0.842
## 5 Virtual Folk Not aware of mo… BEU1… Not at all Not aware of ot… 1.61
## # … with 2 more variables: is.outlier <lgl>, is.extreme <lgl>#aov.dat %>%
# select(Pt_ID,group, piece, aware_body_f, aware_movement_f,aware_others_moving_f, Absorption)%>%
# group_by(piece, group, aware_body_f) %>%
# shapiro_test(Absorption) # the test would not run because sample size was less than 3 in some cells.
## even tho normality was violated, the shapiro test is sensitive at higher sample sizes therefore visual inspection of the qqplot is preferred
ggqqplot(aov.dat, "Absorption", ggtheme = theme_bw()) +
facet_grid(piece + group ~ aware_body_f)
ggqqplot(aov.dat, "Absorption", ggtheme = theme_bw()) +
facet_grid(piece + group ~ aware_movement_f) # 2 cells with only one data point## geom_path: Each group consists of only one observation. Do you need to adjust
## the group aesthetic?
## geom_path: Each group consists of only one observation. Do you need to adjust
## the group aesthetic?
ggqqplot(aov.dat, "Absorption", ggtheme = theme_bw()) +
facet_grid(piece + group ~ aware_others_moving_f) # many cells with only one data point## geom_path: Each group consists of only one observation. Do you need to adjust
## the group aesthetic?
## geom_path: Each group consists of only one observation. Do you need to adjust
## the group aesthetic?
## geom_path: Each group consists of only one observation. Do you need to adjust
## the group aesthetic?
# homogeneity of variances - satisfied
aov.dat %>%
select(Pt_ID,group, piece, aware_body_f, aware_movement_f,aware_others_moving_f, Absorption)%>%
group_by(piece) %>%
levene_test(Absorption ~ group*aware_body_f)## # A tibble: 3 × 5
## piece df1 df2 statistic p
## <fct> <int> <int> <dbl> <dbl>
## 1 Beethoven 6 114 0.786 0.583
## 2 Schnittke 7 109 0.462 0.860
## 3 Folk 7 108 0.995 0.439# homogeneity of covariances - satisfied
box_m(aov.dat[, "Absorption", drop = FALSE], aov.dat$group)## # A tibble: 1 × 4
## statistic p.value parameter method
## <dbl> <dbl> <dbl> <chr>
## 1 0.109 0.741 1 Box's M-test for Homogeneity of Covariance Matric…## Test
# this does not run because of the missing data.
#res.aov<-anova_test(data = aov.dat, dv = Absorption, wid = Pt_ID, within = c(piece, aware_body_f), between = group)
# try with aware_movement - does not work
# res.aov<-anova_test(data = aov.dat, dv = Absorption, wid = Pt_ID, within = c(piece, aware_movement_f), between = group)
# try with aware_others_moving - does not work
# res.aov<-anova_test(data = aov.dat, dv = Absorption, wid = Pt_ID, within = c(piece, aware_others_moving_f), between = group)
#get_anova_table(res.aov)An ANCOVA Approach does not work because there is no var for repeated measures. Multilevel modeling with lme4 is necessary.
No extreme
title = "Relation of Stilling & Absorption"
subtitle= "No Extreme Outliers"
# r
p<-data_u_extreme%>%
ggplot(aes(x = Stilling, y = Absorption))+
geom_point(alpha = .5)+
labs(title =title,subtitle = subtitle, x = "Stilling", y = "Absorption")+
geom_smooth(method = lm)+
facet_grid(rows = vars(piece))+
theme_minimal()+
stat_cor(aes(label = ..r.label..), label.x.npc = .7, color = "blue", geom = "label")#+
#stat_cor(aes(label = ..rr.label..), label.x.npc = .65, color = "blue", geom = "label")+
#stat_cor(aes(label = ..rr.label..), label.x.npc = .65, color = "blue", geom = "label")+
#stat_cor(aes(label = ..r.label..), label.y.npc = .2,label.x.npc = .65, color = "blue", geom = "label")+
#stat_cor(aes(label = paste(..rr.label.., ..p.label.., sep = "~`,`~")), label.x.npc = .6, color = "blue", geom = "label", size = 2.5)+
#stat_cor(aes(label = ..r.label..), label.y.npc = .2,label.x.npc = .65, color = "blue", geom = "label", size = 2.5)
p## `geom_smooth()` using formula 'y ~ x'
graphname<-paste0("../plots/", title,subtitle, ".png")
ggsave(graphname, width = 15, height = 10, units = 'cm', dpi = 500)## `geom_smooth()` using formula 'y ~ x'